R/plotting.R

In jayaraman-lab/neuprintrExtra: Extra functions to analyze neuprint EM datasets

#' Plot a hanesch type plot based on a summary of ROI innervation
#' @param roiTable A table of ROI innervation, as generated by \code{\link{getROISummary}}
#' @param roiSelect A selection of ROIs table, as generated by \code{\link{selectRoiSet}}
#' @param grouping A string of grouping variable(s) of \code{roiTable} to facet the plot on.
#' Will usually be one of the \code{supertype} columns
#' @param flip Flip the x/y axis? If TRUE, types will be on the bottom axis and ROIs on the
#' side axis
#' @param alphaRois The alpha of the color rectangles coding the ROIs
#' @param roiLabel A selection of ROIs, as generated by \code{\link{selectRoiSet}} to be used for the ROI color guide
#' @param regionOutlines Whether or not to add the ROI color code
#' @param theme Theme to be passed to ggplot2
#' @param interactive Whether or not to use some interactivity from ggiraph
#' @param showCount Whether or not to print the number of instances in the type in the tick labels
#'
#' @export
haneschPlot <- function(roiTable,
                        roiSelect=selectRoiSet(getRoiTree()),
                        grouping=NULL,flip=FALSE,
                        alphaRois=0.15,
                        roiLabel=selectRoiSet(getRoiTree(),default_level = 0),
                        regionOutlines=TRUE,
                        theme=theme_minimal(),
                        interactive=FALSE,
                        showCount=FALSE){
  roiTable <- roiTable %>% filter(roi %in% unique(roiSelect$roi))  %>%
    mutate(roi = factor(roi,levels=levels(roiSelect$roi)),
           l4 = roiSelect$level4[match(roi,roiSelect$roi)],
           side = roiSelect$side2[match(roi,roiSelect$roi)],
           superroi = roiLabel$roi[match(l4,roiLabel$level4)]) %>%
    arrange(roi) %>%
    mutate(roiX = match(roi,unique(roi)))

  roiPos <- roiTable %>% group_by(superroi,side) %>%
    summarize(xmin=min(roiX)-0.45,xmax=max(roiX)+0.45) %>%
    ungroup()

  if (showCount)
    roiTable <- mutate(roiTable,yV = paste0(type, " (n= ",n,")"))
  else
    roiTable <- mutate(roiTable,yV=type)

  hanesch <- ggplot(data=roiTable,aes(x=roi,y=yV))

  roiP <- roisPalette()

  if (interactive){
    hanesch <- hanesch + ggiraph::geom_line_interactive(aes(group=yV,data_id=type))
  }else{
    hanesch <- hanesch + geom_line(aes(group=yV))
  }
  if (regionOutlines==TRUE){hanesch <- hanesch +
    geom_rect(data=roiPos,aes(xmin=xmin,xmax=xmax,ymin=-Inf,ymax=Inf,fill=superroi),alpha=alphaRois,inherit.aes = F) +
    scale_fill_manual(name="brain region",values=roiP,guide = guide_legend(reverse = TRUE)) +
    ggnewscale::new_scale_fill()}
  if (interactive){
    hanesch <- hanesch + ggiraph::geom_point_interactive(data=roiTable,
                                                         aes(size=fullWeight,
                                                             fill=deltaWeight,
                                                             x=roi,
                                                             y=yV,
                                                             tooltip=paste0(type," in ",roi,
                                                                            "\nOutputs: ",format(downstream,digits=2,scientific=FALSE),
                                                                            "\nInputs: ",format(upstream,digits=2,scientific=FALSE),
                                                                            "\nn: ",n),
                                                             data_id=type),shape=21)}
  else{
    hanesch <- hanesch +
      geom_point(data=roiTable,aes(size=fullWeight,fill=deltaWeight,x=roi,y=yV),shape=21)}
  hanesch <- hanesch +
    scale_fill_gradient(limits=c(-1,1),name="polarity",breaks=c(-1,-0.5,0,0.5,1),labels=c("receives inputs","","mixed","","sends outputs"),low = "white", high = "black",
                        space = "Lab") +
    guides(fill = guide_legend(override.aes = list(size=5))) +
    scale_size_area(name = "# synapses",breaks=scales::breaks_log(n = 6)) + labs(y="neuron type",x="neuropil") + theme

  if (!(is.null(grouping))){
    if (flip==TRUE){fct <- paste(". ~",grouping)}else{fct <- paste(grouping,"~ .")}
    hanesch <- hanesch + facet_grid(as.formula(fct),scale="free",space="free")
  }

  if (flip==TRUE){hanesch <- hanesch + coord_flip()}
  hanesch + theme(axis.text.x = element_text(angle = 90,hjust = 1,vjust=0.5))

}


#'Plot a connectivity matrix
#'
#'@param connObj A connectivity object. Either a connectivity table, a matrix with \code{dimnames} Inputs and Outputs(as returned by \code{\link{connectivityMatrix}}) or a \code{\link{connectivityCluster}} object.
#'@param slctROI For connectivity tables, you can specify a ROI
#'@param grouping Which variable to use. Will be ignored when \code{connObj} is a \code{\link{connectivityCluster}} 
#'(the decision has already been made while clustering). Any variable postfixed by "to" or "from" in the table is a valid value, as well as "bodyid" and "neuron"
#'@param connectionMeasure Which variable to use as a plotting value
#'@param xaxis Should inputs or outputs be on the x axis (will match the value to "inputs" or "outputs")
#'@param facetInputs Variable to facet the inputs on (nothing by default)
#'@param facetOutputs Variable to facet the outputs on (nothing by default)
#'@param theme A theme to use
#'@param cmax Maximum fill value for the color scale. By default the maximum value found in the table.
#'@param replacementLabels A column prefix to use as a replacement for the axis labels (useful to replace bodyids with names for example)
#'@param orderIn A vector of input bodyid/types/names in the desired order, or a connectivityCluster object. 
#'Optional ordering of the inputs (ignored and replaced by the clustering order if connObj is a connectivityCluster). 
#'@param orderOut A vector of output bodyid/types/names in the desired order, or a connectivityCluster object. 
#'Optional ordering of the outputs (ignored and replaced by the clustering order if connObj is a connectivityCluster).
#'@param legendName Optional override the default name for the color legend (by default a prettification of connectionMeasure)
#'@param showTable When both inputs and outputs have been used for a clustering (via \code{\link{clusterBag}}), which connectivity table to show.
#'@param switch To be passed to \code{\link{ggplot2::facet_grid}} to switch where the facet labels are displayed.
#'@param flipy Option to flip the y axis order
#'@param flipy_facets Option to flip the y axis facets order
#'@details orderIn and orderOut are passed as levels to a factor to order the axis.
#'@return A ggplot object
#'@export
plotConnectivity <- function(connObj,
                             slctROI=NULL,
                             grouping="type",
                             connectionMeasure="weightRelative",
                             xaxis=c("inputs","outputs"),
                             facetInputs=NULL,
                             facetOutputs=NULL,
                             theme=theme_minimal(),
                             cmax=NULL,
                             replacementLabels=NULL,
                             orderIn=NULL,
                             orderOut=NULL,
                             legendName=NULL,
                             showTable="inputs",
                             switch=NULL,
                             flipy=FALSE,
                             flipy_facet=FALSE){
  UseMethod("plotConnectivity")
}

#'@export
plotConnectivity.data.frame <- function(connObj,
                                        slctROI=NULL,
                                        grouping="type",
                                        connectionMeasure="weightRelative",
                                        xaxis=c("outputs","inputs"),
                                        facetInputs=NULL,
                                        facetOutputs=NULL,
                                        theme=theme_minimal(strip.placement = "outside"),
                                        cmax=NULL,
                                        replacementLabels=NULL,
                                        orderIn=NULL,
                                        orderOut=NULL,
                                        legendName=NULL,
                                        showTable="inputs",
                                        switch=NULL,
                                        flipy=FALSE,
                                        flipy_facet=TRUE){
  xaxis <- match.arg(xaxis)
  if(!is.null(slctROI)){connObj <- filter(connObj,roi==slctROI)}
  if(length(unique(connObj$roi))>1){stop("The data frame to plot should only contain one ROI -- you can use the `slctROI` argument")}
  
  if(is.null(cmax)){cmax <- max(connObj[[connectionMeasure]])}
  if(is.null(legendName)){legendName <- stringr::str_to_title(gsub("([a-z])([A-Z])", "\\1 \\2", connectionMeasure))}
  if (grepl("bodyid",grouping) | grepl("neuron",grouping)) {
    groupingName <- "neuron"
    grouping <- ""}else{
      groupingName <- grouping
      grouping=paste0(grouping,".")}
  from <- paste0(grouping,"from")
  to <- paste0(grouping,"to")
  
  if (nrow(distinct_at(connObj,c(from,to,"roi"))) != nrow(connObj)){
    stop(paste0("Multiple entries for some of the ", from,"/",to," combinations. You need to either
         use different from/to or summarize your data.frame beforehand."))}
  
  connObj$Inputs <- connObj[[from]]
  connObj$Outputs <- connObj[[to]]
  
  if (is.null(orderIn)){orderIn <- unique(connObj$Inputs)}
  if (is.null(orderOut)){orderOut <- unique(connObj$Outputs)}
  
  if(is.connectivityCluster(orderIn)){orderIn <- orderIn$hc$labels[orderIn$hc$order]}
  if(is.connectivityCluster(orderOut)){orderOut <- orderOut$hc$labels[orderOut$hc$order]}
  
  connObj$Inputs <- factor(connObj$Inputs,levels=orderIn)
  connObj$Outputs <- factor(connObj$Outputs,levels=orderOut)
  
  if(!is.null(replacementLabels)){
    replacing <- list("from"=connObj[[paste0(replacementLabels,".from")]][match(levels(connObj$Inputs),connObj$Inputs)],
                      "to"=connObj[[paste0(replacementLabels,".to")]][match(levels(connObj$Outputs),connObj$Outputs)])
  }
  
  if (xaxis=="inputs"){
    xVar <- "Inputs"
    yVar <- "Outputs"
  }else{
    xVar <- "Outputs"
    yVar <- "Inputs"
  }
  if (flipy){
    p <- ggplot(connObj,aes(x=!!sym(xVar),y=factor(!!sym(yVar),levels=rev(levels(!!sym(yVar)))),
                            fill=!!(sym(connectionMeasure)))) + geom_tile()
  }else{
    p <- ggplot(connObj,aes(x=!!sym(xVar),y=!!sym(yVar),
                          fill=!!(sym(connectionMeasure)))) + geom_tile()
  }
  
  if (!is.null(facetInputs) | !is.null(facetOutputs)){
    facetInputs <- ifelse(is.null(facetInputs),".",facetInputs)
    facetOutputs <- ifelse(is.null(facetOutputs),".",facetOutputs)
    facetX <- ifelse(xaxis=="inputs",facetInputs,facetOutputs)
    facetY <- ifelse(xaxis=="inputs",facetOutputs,facetInputs)
    if (flipy_facet) facetY <- paste0("reorder(",facetY,",desc(",facetY,"))")
    facetExpr <- paste0(facetY," ~ ",facetX)
    p <- p + facet_grid(as.formula(facetExpr),scale="free",space="free",switch=switch)
  }
  
  if (!is.null(replacementLabels)){
    p <- p + scale_x_discrete(breaks= levels(connObj[[xVar]]),labels=replacing[[ifelse(xaxis=="inputs","from","to")]])+
      scale_y_discrete(breaks= levels(connObj[[yVar]]),labels=replacing[[ifelse(xaxis=="inputs","to","from")]])
  }
  
  p <- p +
    scale_fill_gradient2(name=legendName,low="thistle", mid="blueviolet", high="black", 
                         midpoint =0.5*cmax, limits=c(0,cmax),na.value=NA)  + theme + theme(axis.text.x = element_text(angle = 90,hjust = 1,vjust=0.5))
 
  if (xaxis=="inputs"){
    p <- p + xlab(paste("presynaptic",groupingName)) + ylab(paste("postsynaptic",groupingName))
  } else {
    p <- p + xlab(paste("postsynaptic",groupingName)) + ylab(paste("presynaptic",groupingName))
  }
  p
}

#'@export
plotConnectivity.connectivityCluster <- function(connObj,
                                                 slctROI=NULL,
                                                 grouping=NULL,
                                                 connectionMeasure="weightRelative",
                                                 xaxis=c("inputs","outputs"),
                                                 facetInputs=NULL,
                                                 facetOutputs=NULL,
                                                 theme=theme_minimal(),
                                                 cmax=NULL,
                                                 replacementLabels=NULL,
                                                 orderIn=NULL,
                                                 orderOut=NULL,
                                                 legendName=NULL,
                                                 showTable="inputs",
                                                 switch=NULL,
                                                 flipy=FALSE,
                                                 flipy_facet=FALSE){
  showTable <- match.arg(showTable)
  xaxis <- match.arg(xaxis)
  grouping <- connObj$grouping
  
  if(is.null(connObj$inputsTable)){showTable <- "outputs"}
  if(is.null(connObj$outputsTable)){showTable <- "inputs"}
  
  if(showTable=="inputs"){connTa <- connObj$inputsTable}else{connTa <- connObj$outputsTable}
  
  if(showTable=="inputs"){orderOut <- connObj$hc$labels[connObj$hc$order]
                }else{
    orderIn <- connObj$hc$labels[connObj$hc$order]
  }
  
  plotConnectivity(connTa,grouping=grouping,replacementLabels=replacementLabels,
                   slctROI = slctROI,
                   connectionMeasure=connectionMeasure,facetInputs=facetInputs,facetOutputs=facetOutputs,
                   orderIn=orderIn,orderOut=orderOut,xaxis=xaxis,cmax=cmax,theme=theme,
                   legendName=legendName,switch=switch,flipy=flipy)
}