R/mod_layers.R

In haneylab/geNet: Generating large network of co-occurring genes

############################################################################################
####################### modify layers visualization visnetwork ####################################
############################################################################################

# these functions modify the visualization of the visnetwork based on some info (internal or external)
# they work on the data/data_final object

#' mod_tooltip_visnetwork
#' 
#' function to modify the tooltip layer of the network
#' @param data List of two ffdf objects (format generated by the geNet() function )
#' @param data_new_tooltip dataframe that reports the new tooltip string for each node
#' @return data:  data object modified with the new tooltip layer
#' @export
#' @examples 
#' \dontrun{mod_tooltip_visnetwork(data,data_new_tooltip)}
#' @import ff
mod_tooltip_visnetwork<-function(data,data_new_tooltip=NULL){
  if(is.null(data_new_tooltip)==T){
    return(data)
  }
  if(is.null(data)==T){
    return(NULL)
  }
  print ("-------- assigning new tooltips to the nodes ---------")
  # Note the second column of data_tooltip (after the gene id column) is used as tooltip
  all_gene_id<-as.character(data$nodes$id[]) # All gene ids in the network
  data_tooltip_id<-data_new_tooltip[,1] # the gene ids contained in the dataframe of tooltip info
  new_tooltip_vec<-sapply(1:length(all_gene_id),function(i){
    current_id<-all_gene_id[i]
    ind<-which(data_tooltip_id==current_id)
    if(length(ind)>1){
      print(current_id)
      stop("multiple matches between the gene ids of the network and gene ids of the input data info,
                   please check if data_new_tooltip has unique ids")
    }else if(length(ind)==0){ # the data_info_genes second column does not have an info for this id
      tooltip_current_id<-"no_info"
    }else if(length(ind)==1){ # the data_info_genes second column has an info for this id
      tooltip_current_id<-data_new_tooltip[ind,2]
    }
    return(tooltip_current_id)
  })
  data$nodes$title<-ff(factor(new_tooltip_vec))
  print ("Done")
  return(data)
}



#' mod_group_names
#' 
#' function to modify the names of the group
#' @param data List of two ffdf objects (format generated by the geNet() function )
#' @param df_new_groups_names dataframe that reports the new names for each old group name
#' @return data:  data object modified with the new group names for the current group layer
#' @export
#' @examples 
#' \dontrun{mod_group_names(data,df_new_groups_names)}
#' @import ff
mod_group_names<-function(data,df_new_groups_names=NULL){
  if(is.null(df_new_groups_names)==T){
    return(data)
  }
  if(is.null(data)==T){
    return(NULL)
  }
  print("-------- check new group names df ---------")
  # check for duplicated names
  inds<-which(duplicated(df_new_groups_names[,2])==T)
  if(length(inds)!=0){
    stop("duplicated new names found")
  }
  print ("-------- assigning new group names to the groups ---------")
  
  old_groups_names<-df_new_groups_names[,1]
  new_group_names_vec<-rep("a",nrow(data$nodes))
  i<-0
  for(name in old_groups_names){
    i<-i+1
    inds<-which(as.character(data$nodes$group[])==name)
    new_group_names_vec[inds]<-df_new_groups_names[i,2]
  }
  data$nodes$group<-ff(factor(new_group_names_vec))
  print ("Done")
  return(data)
}
#' mod_color_layer
#' 
#' function to modify the color layer (colors of the node)
#' @param data List of two ffdf objects (format generated by the geNet() function )
#' @param data_new_colors dataframe that reports the new colors for each node
#' @param no_matching_col default color in case of no matching (i.e. gene IDs of the network not reported in data_new_colors)
#' * old: the color of no matching nodes is the old color.
#' * white: the color of no matching nodes is white ("white" is a reserved color)
#' 
#' Default to "white".
#' @return data:  data object modified with the new color layer
#' @export
#' @examples 
#' \dontrun{mod_color_layer(data,data_new_colors,no_matching_col="white")}
#' @import ff
mod_color_layer<-function(data,data_new_colors,no_matching_col="old"){
  if(is.null(data_new_colors)==T){
    return(data)
  }
  if(is.null(data)==T){
    return(NULL)
  }
  print ("-------- assigning new colors names to the nodes ---------")
  output<-any(data_new_colors[,2]=="white")
  if(output==T){
    stop("white is a reserved color. Please replace this color in the input color df")
  }
  all_gene_id<-as.character(data$nodes$id[]) # All gene ids in the network
  data_colors_id<-data_new_colors[,1] # the gene ids contained in the color dataframe
  new_colors_vec<-sapply(1:length(all_gene_id),function(i){
    current_id<-all_gene_id[i]
    ind<-which(data_colors_id==current_id)
    if(length(ind)>1){
      print(current_id)
      stop("multiple matches between the gene ids of the network and gene ids of the input data info,
                   please check if data_new_colors has unique ids")
    }else if(length(ind)==0){ # the data_info_genes second column does not have an info for this id
      color_current_id<- data$nodes$color[][i]
      if(no_matching_col=="white"){
        color_current_id<- "white"
      }
    }else if(length(ind)==1){ # the data_info_genes second column has an info for this id
      color_current_id<-data_new_colors[ind,2]
    }
    return(color_current_id)
  })
  data$nodes$color<-ff(factor(new_colors_vec))
  print ("Done")
  return(data)
}



#' mod_group_layer
#' 
#' function to modify the group layer (influence also the structure of the contracted network)
#' @param data List of two ffdf objects (format generated by the geNet() function )
#' @param data_new_groups dataframe that reports the new group for each node
#' @return data:  data object modified with the new group layer
#' @export
#' @examples 
#' \dontrun{mod_group_layer(data,data_new_groups)}
#' @import ff
mod_group_layer<-function(data,data_new_groups=NULL){
  if(is.null(data_new_groups)==T){
    return(data)
  }
  if(is.null(data)==T){
    return(NULL)
  }
  print("------ assigning new groups to the nodes --------")
  all_gene_id<-as.character(data$nodes$id[]) # All gene ids in the network
  data_groups_id<-data_new_groups[,1] # the gene ids contained in the dataframe of tooltip info
  new_groups_vec<-sapply(1:length(all_gene_id),function(i){
    current_id<-all_gene_id[i]
    ind<-which(data_groups_id==current_id)
    if(length(ind)>1){
      print(current_id)
      stop("multiple matches between the gene ids of the network and gene ids of the input data info,
                   please check if data_new_groups has unique ids")
    }else if(length(ind)==0){ # the data_info_genes second column does not have an info for this id
      group_current_id<- "other_group" 
    }else if(length(ind)==1){ # the data_info_genes second column has an info for this id
      group_current_id<-data_new_groups[ind,2]
    }
    return(group_current_id)
  })
  data$nodes$group<-ff(factor(new_groups_vec))
  print("Done")
  return(data)
}

#' mod_size_layer
#' 
#' function to modify the size layer (size of each node)
#' @param data List of two ffdf objects (format generated by the geNet() function )
#' @param data_new_size dataframe that reports the size for each node
#' @return data:  data object modified with the new size layer
#' @export
#' @examples 
#' \dontrun{mod_size_layer(data,data_new_size)}
#' @import ff
mod_size_layer<-function(data,data_new_size=NULL){
  if(is.null(data_new_size)==T){
    return(data)
  }
  if(is.null(data)==T){
    return(NULL)
  }
  print("------------- assigning new size to the nodes -------")
  all_gene_id<-as.character(data$nodes$id[]) # All gene ids in the network
  data_size_id<-data_new_size[,1] # the gene ids contained in the dataframe of tooltip info
  new_size_vec<-sapply(1:length(all_gene_id),function(i){
    current_id<-all_gene_id[i]
    ind<-which(data_size_id==current_id)
    if(length(ind)>1){
      print(current_id)
      stop("multiple matches between the gene ids of the network and gene ids of the input data info,
                   please check if data_new_size has unique ids")
    }else if(length(ind)==0){ # the data_info_genes second column does not have an info for this id
      size_current_id<- 8 
    }else if(length(ind)==1){ # the data_info_genes second column has an info for this id
      size_current_id<-data_new_size[ind,2]
    }
    return(size_current_id)
  })
  new_size_vec<-as.numeric(new_size_vec)
  data$nodes$size<-ff(new_size_vec)
  print("Done")
  return(data)
}