R/shiny_gui_helpers.R

In SpitzerLab/statisticalScaffold: SCAFFoLD

my_load <- function(f_name)
{
	con <- file(f_name, "rb")
	retval <- unserialize(con)
	close(con)
	return(retval)
}


rescale_size <- function(max.size, min.size, max.val, x)
{
    return(((max.size - min.size) * x) / max.val + min.size);
}

get_vertex_size <- function(sc.data, sel.graph, figure.width, min.node.size, max.node.size, landmark.node.size)
{
    G <- sc.data$graphs[[sel.graph]]
    ret <- V(G)$popsize / sum(V(G)$popsize, na.rm = T)
    ret <- rescale_size(max.node.size, min.node.size, sc.data$dataset.statistics$max.marker.vals[["popsize.relative"]], ret)
    ret[V(G)$type == 1] <- landmark.node.size
    return(ret)
}

get_graph_centering_transform <- function(x, y, svg.width, svg.height)
{
    padding <- 50
    G.width <- max(x) - min(x)
    G.height <- max(y) - min(y)
    scaling <- max(c(G.width / (svg.width - (padding * 2)), G.height / (svg.height - (padding * 2))))
    
    x <- x / scaling
    y <- y / scaling
    
    offset.y <- min(y) - padding
    graph.x.center <- (min(x) + max(x)) / 2
    offset.x <- graph.x.center - (svg.width / 2)
    
    return(list(offset.x = offset.x, offset.y = offset.y, scaling = scaling))
    
    
}

get_graph_table <- function(sc.data, sel.graph)
{
    G <- sc.data$graphs[[sel.graph]]
    ret <- get.data.frame(G, what = c("vertices"))
    return(ret)
}


get_summary_table <- function(sc.data, sel.graph, sel.nodes)
{
    G <- sc.data$graphs[[sel.graph]]
    col.names <- get_numeric_vertex_attributes(sc.data, sel.graph)
    tab <- get.data.frame(G, what = "vertices")
    temp <-tab[tab$Label %in% sel.nodes,]
    ret <- temp[, col.names]    
    ret <- rbind(ret, apply(ret, 2, median, na.rm = T))
    popsize <- data.frame(Cells = temp$popsize, Percentage = temp$popsize / sum(tab$popsize[tab$type == 2]))
    popsize <- rbind(popsize, colSums(popsize))
    ret <- cbind(popsize, ret)
    ret <- data.frame(Label = c(temp$Label, "Summary"), ret)
    ret$Percentage <- signif(ret$Percentage * 100, digits = 4)
    return(ret)
}


cleanPlotMarkers <- function(allMarkers,forMap = FALSE) {
  cleanMarkers = as.character(allMarkers)
  if(forMap == FALSE) {
    if(any(grep("Signif", cleanMarkers))) {cleanMarkers =  cleanMarkers[-grep("Signif", cleanMarkers)]}
    if(any(grep("FoldChange", cleanMarkers))) {cleanMarkers =  cleanMarkers[-grep("FoldChange", cleanMarkers)]}
    if(any(grep("correlation", cleanMarkers))) {cleanMarkers =  cleanMarkers[-grep("correlation", cleanMarkers)]}
  }
  return(cleanMarkers)
}


export_clusters <- function(working.dir, sel.graph, sel.nodes)
{
    d <- gsub(".txt$", ".all_events.RData", sel.graph)
    d <- file.path(working.dir, d)
    d <- my_load(d)
    clus <- as.numeric(gsub("c", "", sel.nodes))
    d <- d[d$cellType %in% clus,]
    f <- flowFrame(as.matrix(d))
    p <- sprintf("scaffold_export_%s_", gsub(".fcs.clustered.txt", "", sel.graph))
    outname <- tempfile(pattern = p, tmpdir = working.dir, fileext = ".fcs")
    print(outname)
    write.FCS(f, outname)
}

##Added this function to export a cluster(s) from all files in the directory
export_clusters_all_files <- function(working.dir, sel.graph, sel.nodes)
{
    filesToIterate = as.matrix(list.files(working.dir, pattern = ".txt$"))
    
    exportFromFile = function(file) {
        d <- gsub(".txt$", ".all_events.RData", file)
        d <- file.path(working.dir, d)
        d <- my_load(d)
        clus <- as.numeric(gsub("c", "", sel.nodes))
        d <- d[d$cellType %in% clus,]
        if (length(as.matrix(d)[,1]) >= 1) {
            f <- flowFrame(as.matrix(d))
            p <- sprintf("scaffold_export_%s_", gsub(".fcs.clustered.txt", "", file))
            outname <- tempfile(pattern = p, tmpdir = working.dir, fileext = ".fcs")
            print(outname)
            write.FCS(f, outname)  
        }
    }
    
    apply(filesToIterate, 1, exportFromFile)
}

# ##Added this function to run set cluster vectors for Histogram Intersection Distance
# set_HID_vectors <- function(vector, sel.nodes, working.directory, nameDirectory)
# {
#   if(!(nameDirectory %in% list.dirs(full.names = FALSE))) {dir.create(paste(working.directory,nameDirectory, sep = "/"))}
#   
#   if (all(substr(sel.nodes,1,1) == "c")) {
#   sel.nodes = as.numeric(gsub("c", "", sel.nodes))
#   }
#   if(vector == "vector1") {
#     setVector1 = sel.nodes
#     write.csv(setVector1, file = paste(working.directory,nameDirectory, "Vector1.csv", sep="/"),
#               row.names=FALSE)
#   }else if (vector == "vector2") {
#     setVector2 = sel.nodes
#     write.csv(setVector2, file = paste(working.directory,nameDirectory, "Vector2.csv", sep="/"),
#               row.names=FALSE)
#   }
# }

get_graph <- function(sc.data, sel.graph, trans_to_apply, min.node.size, max.node.size, landmark.node.size)
{
    G <- sc.data$graphs[[sel.graph]]
    edges <- data.frame(get.edgelist(G, names = F) - 1)
    colnames(edges) <- c("source", "target")
    svg.width <- 1200
    svg.height <- 800
    svg.center <- c(svg.width / 2, svg.height / 2)
    
    x <- V(G)$x
    y <- V(G)$y
    
    y <- -1 * y
    x <- x + abs(min(x))
    y <- y + abs(min(y))
    num.landmarks <- sum(V(G)$type == 1)
    trans <- get_graph_centering_transform(x[V(G)$type == 1], y[V(G)$type == 1], svg.width, svg.height)
    
    x <- (x / trans$scaling) - trans$offset.x
    y <- (y / trans$scaling) - trans$offset.y
    
    vertex.size <- get_vertex_size(sc.data, sel.graph, svg.width, min.node.size, max.node.size, landmark.node.size)
    edges <- cbind(edges, x1 = x[edges[, "source"] + 1], x2 = x[edges[, "target"] + 1])
    edges <- cbind(edges, y1 = y[edges[, "source"] + 1], y2 = y[edges[, "target"] + 1])
    edges <- cbind(edges, id = 1:nrow(edges))
    edges <- cbind(edges, is_highest_scoring = 0)
    edges <- cbind(edges, edge_type = "")
    #Set as true for the highest scoring edges of type 2 vertices
    edges[, "is_highest_scoring"][V(G)$highest_scoring_edge[V(G)$type == 2]] <- 1
    if("edge_type" %in% list.edge.attributes(G)) #Old graphs did not have this
        edges[, "edge_type"] <- E(G)$edge_type
    #print(G)
    ret <- list(names = V(G)$Label, size = vertex.size / trans$scaling, type = V(G)$type, highest_scoring_edge = V(G)$highest_scoring_edge, X = x, Y = y, trans_to_apply = trans_to_apply)
    ret <- c(ret, edges = list(edges))
    
    return(ret)
}

get_color_for_marker <- function(sc.data, sel.marker, sel.graph, color.scaling)
{
    G <- sc.data$graphs[[sel.graph]]  
    
    ret = rep("#4F93DE", vcount(G))
    ret[V(G)$type == 1] <- "#FF7580"
    v = ret

    if (grepl("Signif", sel.marker) || grepl("FoldChange", sel.marker)) {
      
        v <- get.vertex.attribute(G, sel.marker)
      
        a = "#E7E7E7"
        b = "#E71601"
        c = "#2001E7"
        f <- colorRamp(c(c, a, b), interpolate = "linear")
        
        v <- f(v) #colorRamp needs an argument in the range [0, 1] 
        v <- apply(v, 1, function(x) {sprintf("rgb(%s)", paste(round(x), collapse = ","))})
        
        ##Landmark nodes black
        v[V(G)$type == 1] <- "#000000"  
        return(v)
    }
    else if (grepl("correlation", sel.marker)) {
      v <- get.vertex.attribute(G, sel.marker)
      
      #scales data from -1 to 1 TO 0 to 1
      v <- (v+1)/2
      
      a = "#E7E7E7"
      b = "#1f7f2e"
      c = "#934e14"
      f <- colorRamp(c(c, a, b), interpolate = "linear")
      
      v <- f(v) #colorRamp needs an argument in the range [0, 1] 
      v <- apply(v, 1, function(x) {sprintf("rgb(%s)", paste(round(x), collapse = ","))})
      
      ##Landmark nodes black
      v[V(G)$type == 1] <- "#000000"  
      return(v)
    }
    else if (sel.marker != "Default")
    {
        norm.factor <- NULL
        v <- get.vertex.attribute(G, sel.marker)
        if(color.scaling  == "global")
            norm.factor <- sc.data$dataset.statistics$max.marker.vals[[sel.marker]]
        else if(color.scaling == "local")
            norm.factor <- max(v)
        
        a = "#E7E7E7"
        b = "#E71601"
        f <- colorRamp(c(a, b), interpolate = "linear")
        
        v <- f(v / norm.factor) #colorRamp needs an argument in the range [0, 1]
        v <- apply(v, 1, function(x) {sprintf("rgb(%s)", paste(round(x), collapse = ","))})
        return(v)
    }
    else
    {
      return(ret)
    }
}

get_numeric_vertex_attributes <- function(sc.data, sel.graph)
{
    G <- sc.data$graphs[[sel.graph]]
    d <- get.data.frame(G, what = "vertices")
    #Don't consider attributes which are only present in the landmarks
    d <- d[d$type == 2,]
    num <- sapply(d, function(x) {is.numeric(x) && !any(is.na(x))})
    v <- list.vertex.attributes(G)[num]
    exclude <- c("x", "y", "cellType", "type", "groups", "popsize", "r", "g", "b", "size", "DNA1", "DNA2", "BC1", "BC2", "BC3", "BC4", "BC5", "BC6", "Time", "Cell_length", "Cisplatin", "beadDist", "highest_scoring_edge")
    return(v[!(v %in% exclude)])
}

get_number_of_cells_per_landmark <- function(sc.data, sel.graph)
{
    G <- sc.data$graphs[[sel.graph]]
    land <- V(G)[V(G)$type == 1]$Label
    ee <- get.edgelist(G)
    ee <- ee[V(G)[V(G)$type == 2]$highest_scoring_edge,]
    vv <- V(G)[as.numeric(ee[,2])]
    popsize <- V(G)[vv]$popsize
    dd <- data.frame(Landmark = ee[,1], popsize)
    dd <- ddply(dd, ~Landmark, function(x) {sum(x["popsize"])})
    dd <- cbind(dd, Percentage = dd$V1 / sum(dd$V1))
    names(dd) <- c("Landmark", "Cells", "Percentage")
    dd$Percentage <- signif(dd$Percentage * 100, digits = 4)
    return(dd)
}


#added 10/29/18 to export all cluster to landmark information
get_cluster_label <- function(sc.data, working.directory) 
{ 
  G <- sc.data$graphs[[1]]
  
  #exports key landmark population per cluster
  ee <- get.edgelist(G)
  ee1 <- ee[V(G)[V(G)$type == 2]$highest_scoring_edge,]
  dd <- data.frame(Cluster = c(1:nrow(ee1)), Landmark = ee1[,1])
  write.csv(dd, file = paste(working.directory, "HighestRanking_ClusterInfo.csv", sep="/"),row.names=FALSE) 
  
  # expots every landmark node connection per cluster, with weight of connection
  g.temp <- delete.edges(G, E(G)[which(E(G)$edge_type == "inter_cluster")])
  allClusterInfo <- data.frame(Cluster = c(1:nrow(ee1)))
  namevector <- unique(get.edgelist(g.temp)[,1])
  allClusterInfo[ , namevector] <- NA
  node = 1
  for(i in 1:vcount(g.temp))
  {
    if(V(g.temp)$type[i] == 2)
    {
      sel.edges <- incident(g.temp, i)
      node_name <- ee[which(ee[,2] == i),1]
      node_weight <- E(g.temp)[sel.edges]$weight
      allClusterInfo[node,which(colnames(allClusterInfo) %in% node_name)] = node_weight
      node = node + 1
    }
  }
  write.csv(allClusterInfo, file = paste(working.directory, "ALL_ClusterInfo.csv", sep="/"),row.names=FALSE) 
}


get_fcs_col_names <- function(working.directory, f.name)
{
    fcs.file <- read.FCS(paste(working.directory, f.name, sep = "/"))
    ret <- as.vector(pData(parameters(fcs.file))$desc)

    if(any(is.na(ret)))
    {
        w <- is.na(ret)
        ret[w] <- as.vector(pData(parameters(fcs.file))$name[w])
    }
    
    return(ret)
}





#get_pubmed_references <- function(sc.data, sel.graph, node.label)
#{
#    G <- sc.data$graphs[[sel.graph]]
#    ret <- ""
#    if("desc" %in% list.vertex.attributes(G))
#    {
#        ret <- sprintf("List of references for landmark %s:<br>", gsub(".fcs", "", node.label))
#        v <- strsplit(V(G)[V(G)$Label == node.label]$desc, ",")[[1]]
#        v <- paste(sapply(v, function(x) {sprintf("PMID: <a href='http://www.ncbi.nlm.nih.gov/pubmed/%s' target='_blank'>%s</a><br>", x, x) }), collapse = "")
#        ret <- paste(ret, v, sep = "")
#    }
#    return(HTML(ret))
#}