R/Viz_manipul_main.R

Defines functions onto_process map_obj export_cytoscape export_annotations make_shiny_in get_part_anc get_part_descen paths_sunburst chars_per_term get_ancestors_chars get_descendants_chars edges2list list2edges table2list

Documented in chars_per_term edges2list export_annotations export_cytoscape get_ancestors_chars get_descendants_chars list2edges make_shiny_in onto_process paths_sunburst table2list

#' @title Convert table to list
#' @description Takes table where each row consists of charcter number and ontology annotations and returns a list.
#' Each character is assigned its own ID CHAR:XXXX
#' @param table A character table with annotations.
#' @param id_col A column ID corresponding to character
#' @param descendants_cols IDs of columns corresponding to character annotations
#' @return The list.
#' @examples
#' # converting Sharkey_2011 data set to list of characater states
#' list_data<-table2list(Sharkey_2011)
#' @export

table2list<-function(table, id_col=c(1), descendants_cols=c(2:ncol(table))){
annotated.char.list=list()
for (i in 1:nrow(table)) {
  annotated.char.list[[i]]=c(na.omit(as.character(table[i,descendants_cols])))
}
#names(annotated.char.list)<-paste("CHAR:", table[,id_col], sep="")
return(annotated.char.list)
}
#annotated.char.list=table2list(char.dt, 1, 3:9)



#' @title Convert list to edge matrix
#' @description Takes list of charater annotations amd creates an edge matrix comprising two columns: from and to.
#' The list to table conversion can be done using ldply function from plyr package: plyr::ldply(list, rbind).
#' @param annotated.char.list Character list with ontology annotations.
#' @param col_order_inverse The default creates the first columns consisting if character IDs and the second columns consisting of ontology annatotaions.
#' The inverse order changes the columns order.
#' @return Two-column matrix.
#' @examples
#' annot_list<-list(`CHAR:1`=c("HAO:0000933", "HAO:0000958"), `CHAR:2`=c("HAO:0000833", "HAO:0000258"))
#' list2edges(annot_list)
#' # attache plyr package and run
#' # ldply(annot_list, rbind)
#' @export

list2edges<-function(annotated.char.list, col_order_inverse=F){
annotated.vec=setNames(unlist(annotated.char.list, use.names=F),rep(names(annotated.char.list), lengths(annotated.char.list)))
if (col_order_inverse==T){
  edge.matrix=cbind(unname(annotated.vec), names(annotated.vec))
} else
edge.matrix=cbind(names(annotated.vec), unname(annotated.vec))
return(edge.matrix)
}




#' @title Convert edge matrix to list
#' @description Takes two columns edge matrix (columns from and two) and produces list
#' @param edge.matrix Two-columns edge matrix.
#' @return The list.
#' @examples
#' annot_list<-list(`CHAR:1`=c("HAO:0000933", "HAO:0000958"), `CHAR:2`=c("HAO:0000833", "HAO:0000258"))
#' edge.matrix<-list2edges(annot_list)
#' edges2list(edge.matrix)
#' @export

edges2list<-function(edge.matrix){
uniq_ids=unique(edge.matrix[,1])
list.from.edge=list()
for (i in 1:length(uniq_ids)){
  char.ids=which(edge.matrix[,1]==uniq_ids[i])
  list.from.edge[[i]]=edge.matrix[char.ids,2]
}
names(list.from.edge)<-uniq_ids
return(list.from.edge)
}



#' @title Get characters that descendants of selected ontology term
#' @description Returns all characters located (associated) with a given ontology terms
#' @param ontology ontology_index object.
#' @param annotations which annotations to use: "auto" means automatic annotations, "manual" means manual ones.
#' Alternatively, any othe list element containing annotations can be specified.
#' @param terms IDs of ontology terms for which descendants are queried.
#' @param ... other parameters for ontologyIndex::get_descendants() function
#' @return The vector of character IDs.
#' @examples
#' ontology<-HAO
#' ontology$terms_selected_id<-list(`CHAR:1`=c("HAO:0000653"), `CHAR:2`=c("HAO:0000653"))
#' get_descendants_chars(ontology, annotations="manual", "HAO:0000653")
#' @export

get_descendants_chars<-function(ontology, annotations="auto", terms, ...){

  if (is.list(annotations)){
    annot_list<-annotations # specify your annotation list
  } else {

    if (annotations=="auto"){
      annot_list<-ontology$auto_annot_characters
    }
    if (annotations=="manual"){
      annot_list<-ontology$terms_selected_id
    }
  }


  onto_chars_list=list2edges(annot_list, col_order_inverse=T)
  descen<-unique(onto_chars_list[,2][onto_chars_list[,1] %in%
                                       ontologyIndex::get_descendants(ontology=ontology, roots=terms, ...)])
  return(descen)
}




#' @title Get ancestal ontology terms for a set of characters
#' @description Returns all ontology terms which are ancestors of a given character set
#' @param ontology ontology_index object with character annatotions included (ontology$annot_characters).
#' @param char_id IDs of character.
#' @param annotations which annotations to use: "auto" means automatic annotations, "manual" means manual ones.
#' Alternatively, any othe list element containing annotations can be specified.
#' @return The vector of ontology terms IDs.
#' @examples
#' ontology<-HAO
#' ontology$terms_selected_id<-list(`CHAR:1`=c("HAO:0000653"), `CHAR:2`=c("HAO:0000653"))
#' get_ancestors_chars(ontology, c("CHAR:1","CHAR:2"), annotations="manual")
#' @export

get_ancestors_chars<-function(ontology, char_id, annotations="auto" ){

  if (is.list(annotations)){
    annot_list<-annotations # specify your annotation list
  } else {

    if (annotations=="auto"){
      annot_list<-ontology$auto_annot_characters
    }
    if (annotations=="manual"){
      annot_list<-ontology$terms_selected_id
    }
  }


  ontologyIndex::get_ancestors(ontology, unlist(annot_list[char_id], use.names = FALSE))
}





#' @title Get number of chracters per each ontology term
#' @description Returns matrix summarizing  number of characters per each ontology terms in descending order
#' @param ontology ontology_index object with character annatotions included (ontology$annot_characters).
#' @param annotations which annotations to use: "auto" means automatic annotations, "manual" means manual ones.
#' Alternatively, any othe list element containing annotations can be specified.
#' @return The matrix of ontology terms IDs, their names and character number.
#' @examples
#' ontology<-HAO
#' ontology$terms_selected_id<-list(`CHAR:1`=c("HAO:0000653"), `CHAR:2`=c("HAO:0000653"))
#' chars_per_term(ontology, annotations="manual")
#' @export


chars_per_term<-function(ontology, annotations="auto"){

  all_des=pblapply(ontology$id, function(x) {get_descendants_chars(ontology, annotations=annotations, x)})
  char_per_term=unlist(lapply(all_des, length))
  term_tb=char_per_term[order(char_per_term, decreasing=T)]
  term_tb=cbind(names(term_tb), get_onto_name(names(term_tb), ontology, names=F), unname(term_tb))
  colnames(term_tb)<-c("ID", "names", "N_chars")
  return(term_tb)
}
#terms_tb=chars_per_term(hao.obo)
#write.csv(terms_tb, file="n_characters_per_term.csv")


#' @title Return ontology paths for characters
#' @description Returns ontology paths for all characters. These paths can be used to create a sunburst plot of
#' ontological dependencies.
#' @param ontology ontology_index object with character annatotions included.
#' @param annotations which annotations to use: "auto" means automatic annotations, "manual" means manual ones.
#' Alternatively, any othe list element containing annotations can be specified.
#' @param exclude.terms list of terms to exclude
#' @param sep separator used to delimit ontology terms
#' @return Table.
#' @examples
#' # reading in ontology and part_of relatinships only
#' # ontology_partof=get_OBO(system.file("data_onto", "HAO.obo", package = "ontoFAST"),
#' #                        extract_tags="everything", propagate_relationships = c("BFO:0000050"))
#' # atomatically annotating ontology
#' # ontology_partof<-onto_process(ontology_partof, Sharkey_2011[,1])
#' # creating character paths; exluding redundant terms
#' # tb<-paths_sunburst(ontology_partof, annotations = ontology_annot$auto_annot_characters, exclude.terms=exclude_terms)
#' # intall sunburstR package if you lack it
#' # library(sunburstR)
#' # create sunburst plot
#' # sunburst(tb)
#' @export

paths_sunburst<-function(ontology, annotations="auto", exclude.terms=NULL, sep="-"){

  if (is.list(annotations)){
    annot_list<-annotations # specify your annotation list
  } else {

    if (annotations=="auto"){
      annot_list<-ontology$auto_annot_characters
    }
    if (annotations=="manual"){
      annot_list<-ontology$terms_selected_id
    }
  }

  annot_list<-list2edges(annot_list)

  f<-function(char_id) {
    anc<-get_onto_name(ontologyIndex::get_ancestors(ontology, char_id), ontology)
    # if (length(exclude.terms)>1){
    anc<-anc[!anc%in%exclude.terms]
    # }
    return(anc)
  }

  list_paths=c()
  for (i in 1:nrow(annot_list)){
    list_paths=c(list_paths, paste(c( gsub("-", " ", f(annot_list[i,2])),
                                      annot_list[i,1]), collapse=sep))
  }


  tb<-data.frame(paths=list_paths, count=rep(1, length(list_paths)), stringsAsFactors =F)

  return(tb)

}




#
# #' @title Makes dataframe of descndanrts to plot using visNetwork
# #' @description Returns a list of two dataframes: nodes and edges
# #' @param ontology ontology_index object.
# #' @param terms temr id for which descendants to be displayed
# #' @param is_a id of how is_a relationships are coded in ontology.
# #' To no included in output use NA.
# #' @param part_of same as previous
# #' @param color color for is_a and part_of relationships
# #' @param all_links whether all links (is_a and part_of) which link descendants with other nodes must be included in the output.
# #' Better not use as it makes the output messy.
# #' @param incl.top.anc include the parents of terms
# #' @param highliht_focus whether terms mus be highlited
# #' @return The list of dataframes.
# #' @examples
# #' dt=get_part_descen(hao.obo, get_onto_id("mouthparts", ontology) , is_a=c("is_a"), part_of=c("BFO:0000050"))
# #' visNetwork(dt$nodes, dt$edges, width = "100%", height = "100%") %>%
# #' visNodes(borderWidthSelected=4)%>%
# #' visOptions(highlightNearest = TRUE)%>%
# #' visLayout(randomSeed = 12)
#

get_part_descen<-function(ontology, terms, is_a=c("is_a"), part_of=c("BFO:0000050"), color=c("red", "blue"),
                          all_links=F, incl.top.anc=T, highliht_focus=T){
  des=get_descendants(ontology, terms)
  all_edges=c()
  if (all_links){ k=1
  }else k=2

  if (length(is_a)>0){
    edges=list2edges(ontology[[is_a]])
    rows=which(edges[,k]%in%des==T)
    if (length(rows)>0){
      if (incl.top.anc){ rows=c(rows, which(edges[,1]%in%terms==T))}
      all_edges=cbind(matrix(edges[rows,], ncol = 2), color[1])
      #all_edges=cbind(edges[rows,], color[1])
    }
  }

  if (length(part_of)>0){
    edges=list2edges(ontology[[part_of]])
    rows=which(edges[,1]%in%des==T)
    if (length(rows)>0){
      if (incl.top.anc){ rows=c(rows, which(edges[,1]%in%terms==T))}
      all_edges=rbind(all_edges, cbind(matrix(edges[rows,], ncol = 2), color[2]))
      #all_edges=rbind(all_edges, cbind(edges[rows,], color[2]))
    }
  }

  if(is.null(all_edges)==T) return(dt=list(nodes=NULL, edges=NULL))

  #nodes=unique(des)
  nodes=unique(c(all_edges[,1], all_edges[,2]))
  nodes_color<-rep(NA, length(nodes))
  if (highliht_focus){nodes_color[which(nodes==terms)]<-"orange"}

  dt_nodes=data.frame(id=nodes,
                      label=get_onto_name(nodes, ontology),
                      title=nodes,
                      color.background =nodes_color,
                      color.highlight.background=nodes_color)


  dt_edges=data.frame(from=all_edges[,1],
                      to=all_edges[,2],
                      arrows="to",
                      color=all_edges[,3])
  dt=list(nodes=dt_nodes, edges=dt_edges)
  return(dt)
}

# dt=get_part_descen(hao.obo, get_onto_id("mouthparts", ontology) , is_a=c("is_a"), part_of=c("BFO:0000050"))
#
# get_part_descen(hao.obo, "HAO:0000011", is_a=c("is_a"), part_of=c("BFO:0000050"))
#
# dt=get_part_descen(hao.obo, get_onto_id("thorax", ontology) , is_a=c("is_a"), part_of=c("BFO:0000050"))
#
# visNetwork(dt$nodes, dt$edges, width = "100%", height = "100%") %>%
#   visNodes(borderWidthSelected=4)%>%
#   visOptions(highlightNearest = TRUE)%>%
#   visLayout(randomSeed = 12)
#
# visNetwork(dt$nodes, dt$edges, width = "100%", height = "100%") %>%
#   visNodes(borderWidthSelected=4)%>%
#   visOptions(highlightNearest = TRUE)%>%
#   visLayout(randomSeed = 12) %>%
#   visIgraphLayout(layout="layout_with_gem")




#
# #' @title Makes dataframe of ancestors to plot using visNetwork
# #' @description Returns a list of two dataframes: nodes and edges
# #' @param ontology ontology_index object.
# #' @param terms temr id for which descendants to be displayed
# #' @param is_a id of how is_a relationships are coded in ontology.
# #' To no included in output use NA.
# #' @param part_of same as previous
# #' @param color color for is_a and part_of relationships
# #' @param all_links whether all links (is_a and part_of) which link descendants with other nodes must be included in the output.
# #' Better not use as it makes the output messy.
# #' @param incl.top.anc include the parents of terms
# #' @param highliht_focus whether terms mus be highlited
# #' @return The list of dataframes.
# #' @examples
# #' dt=get_part_anc(hao.obo, get_onto_id("mouthparts", ontology) , is_a=c("is_a"), part_of=c("BFO:0000050"))
# #' visNetwork(dt$nodes, dt$edges, width = "100%", height = "100%") %>%
# #' visNodes(borderWidthSelected=4)%>%
# #' visOptions(highlightNearest = TRUE)%>%
# #' visLayout(randomSeed = 12)


get_part_anc<-function(ontology, terms, is_a=c("is_a"), part_of=c("BFO:0000050"), color=c("red", "blue"),
                          all_links=F, incl.top.anc=T, highliht_focus=T){
  des=get_ancestors(ontology, terms)
  all_edges=c()
  if (all_links){ k=2
  }else k=1

  if (length(is_a)>0){
    edges=list2edges(ontology[[is_a]])
    rows=which(edges[,k]%in%des==T)
    if (length(rows)>0){
      if (incl.top.anc){ rows=c(rows, which(edges[,1]%in%terms==T))}
      all_edges=cbind(matrix(edges[rows,], ncol = 2), color[1])
      #all_edges=cbind(edges[rows,], color[1])
    }
  }

  if (length(part_of)>0){
    edges=list2edges(ontology[[part_of]])
    rows=which(edges[,2]%in%des==T)
    if (length(rows)>0){
      if (incl.top.anc){ rows=c(rows, which(edges[,1]%in%terms==T))}
      all_edges=rbind(all_edges, cbind(matrix(edges[rows,], ncol = 2), color[2]))
      #all_edges=rbind(all_edges, cbind(edges[rows,], color[2]))
    }
  }

  if(is.null(all_edges)==T) return(dt=list(nodes=NULL, edges=NULL))

  #nodes=unique(des)
  nodes=unique(c(all_edges[,1], all_edges[,2]))
  nodes_color<-rep(NA, length(nodes))
  if (highliht_focus){nodes_color[which(nodes==terms)]<-"orange"}

  dt_nodes=data.frame(id=nodes,
                      label=get_onto_name(nodes, ontology),
                      title=nodes,
                      color.background =nodes_color,
                      color.highlight.background=nodes_color)


  dt_edges=data.frame(from=all_edges[,1],
                      to=all_edges[,2],
                      arrows="to",
                      color=all_edges[,3])
  dt=list(nodes=dt_nodes, edges=dt_edges)
  return(dt)
}



#' @title Make ontology object for vizualization
#' @description Make ontology object for vizualization
#' @param ontology Ontology
#' @return Ontology index object named as shiny_in.
#' @examples
#' make_shiny_in(HAO)
#' @export

make_shiny_in<-function(ontology){

shiny_in<- ontology
shiny_in$terms_selected<-list()
shiny_in$terms_selected_id<-list()

#map between term_id_name and term_id
shiny_in$terms_map<-paste(unname(ontology$name), paste(", ", names(ontology$name), sep=""), sep="")
names(shiny_in$terms_map)<-names(ontology$name)

# making serch terms for Selectize using synonyms
shiny_in$srch_items<-c(names(ontology$name), names(ontology$parsed_synonyms))
names(shiny_in$srch_items)<-c(
  paste(unname(ontology$name), names(ontology$name), sep=", "),
                              paste(unname(ontology$parsed_synonyms), get_onto_name(names(ontology$parsed_synonyms), ontology),
                                    sep=" <synonym of> ")
                              )


# rendering auto annotations with IDs and names
shiny_in$auto_annot_characters_id_name <-lapply(
  ontology$auto_annot_characters, function(x) {
    paste(get_onto_name(x, ontology), paste(", ", x, sep=""), sep="")
    })
shiny_in$auto_annot_characters_id_name[shiny_in$auto_annot_characters_id_name ==", "]<-NULL #making empty annot as na


return(shiny_in)
}



#' @title Export annotation data
#' @description This function converts character annotations stored in shiny_in object to table format.
#' @param ontology Ontology
#' @param annotations which annotations to use: "auto" means automatic annotations, "manual" means manual ones.
#' Alternatively, any othe list element containing annotations can be specified.
#' @param incl.names if TRUE includes terms' names and IDs, otherwise includes just IDs.
#' @param sep.head if incl.names=TRUE, this is a separator attached to the begining of term's ID
#' @param sep.tail if incl.names=TRUE, this is a separator attached to the end of term's ID
#' @param collapse if NULL all annotations of a term placed in separate columns, if a value is specified (e.g., "; ") then all anotations
#' are collapsed in one line given that values
#' @return Returns a table
#' @examples
#' # tb<-export_annotations(shiny_in, annotations="manual", incl.names=T,collapse="; ")
#' # tb<-export_annotations(shiny_in, annotations="auto", incl.names=T,collapse="; ")
#' # tb<-export_annotations(shiny_in, annotations="auto", incl.names=T,collapse=NULL)
#' # save annotations in csv
#' # write.csv(tb, "annotated_characters.csv")
#' @export


export_annotations<-function(ontology, annotations="auto", incl.names=F, sep.head=", ", sep.tail=NULL, collapse=NULL){

  if (is.list(annotations)){
    annot_list<-annotations # specify your annotation list
  } else {

    if (annotations=="auto"){
      annot_list<-ontology$auto_annot_characters
    }
    if (annotations=="manual"){
      annot_list<-ontology$terms_selected_id
    }
  }

  annot.export<-annot_list

  if (incl.names==TRUE){
    annot.export<- lapply(
    annot_list, function(x) {
      paste(get_onto_name(x, ontology), paste(sep.head, x, sep.tail, sep=""), sep="")
    })
  }

 #annot.export[["CHAR:391"]]<-NULL
  annot.export[annot.export ==", "]<-NA

  #which are absent
 absent<-ontology$id_characters[!(ontology$id_characters %in% names(annot.export))]

 # insert absent
 annot.export<-c(annot.export, as.list(setNames(rep(NA, length(absent)), absent)))

 #sort list
 annot.export<-annot.export[ontology$id_characters]

 annot.export<-lapply(annot.export, function(x){paste(x, collapse=collapse)})


 table_annot<-plyr::ldply(annot.export, rbind)
 table_annot<-as.matrix(table_annot)
 table_annot<-cbind(table_annot[,1], unname(ontology$name_characters), table_annot[,2:ncol(table_annot)])
 colnames(table_annot)<-c("ID", "Character statement", rep("Annotation", ncol(table_annot)-2))

 return(table_annot)


}

#' @title Export to Cytoscape format
#' @description This function converts character annotations to Cytoscape format. It returns a table that can be saved as in csv format
#' and imported using Cytoscape. In Cytoscape choose File -> Import -> Network -> File. The assign columns to nodes and edges. Do not select
#' columns that enumerated the tables' rows.
#' @param ontology Ontology
#' @param annotations which annotations to use: "auto" means automatic annotations, "manual" means manual ones.
#' Alternatively, any othe list element containing annotations can be specified.
#' @param is_a is_a
#' @param part_of part_of
#' @return Returns a table
#' @examples
#' # cyto<-export_cytoscape(shiny_in)
#' # write.csv(cyto, "cyto_exp.csv")
#' @export


export_cytoscape<-function(ontology, annotations="auto", is_a=c("is_a"), part_of=c("BFO:0000050")   ){

  if (is.list(annotations)){
    annot_list<-annotations # specify your annotation list
  } else {

    if (annotations=="auto"){
      annot_list<-ontology$auto_annot_characters
    }
    if (annotations=="manual"){
      annot_list<-ontology$terms_selected_id
    }
  }


  # get Part_of relatinshisp
  partof<-list2edges(ontology[[part_of]])
  partof<-cbind(partof, rep("part_of", nrow(partof)))
  partof<-cbind(get_onto_name(partof[,1], ontology), partof)

  # get is_a
  isa<-list2edges(ontology[[is_a]])
  isa<-cbind(isa, rep("is_a", nrow(isa)))
  isa<-cbind(get_onto_name(isa[,1], ontology), isa)

  # get char_of
  charof<-list2edges(annot_list)
  charof<-cbind(charof, rep("char_of", nrow(charof)))
  charof<-cbind(unname(
  ontology$name_characters[c(na.omit(match(unlist(charof[,1], use.names = FALSE), names(ontology$name_characters)  )))]
  ), charof)

  # bind all
  cyto<-rbind(charof, partof, isa)

  return(cyto)

}




####Function to create mapping for Shiny objects
map_obj<-function(obj, nchar){
  map_f=paste(obj, c(1:nchar), sep="")
  names(map_f)<-paste(c(1:nchar), sep="")
  return(map_f)
}
#############



#' @title Shortcut to process characters and ontology
#' @description This is a shortcut function to make characters and ontology suitable for visualization using ontoFAST interactive tools.
#' @param ontology Ontology
#' @param name_characters a vector of character names
#' @param do.annot specifiees if you need to run automatic annotations or not
#' @return Ontology index object named
#' @examples
#' ## automatically preprocess ontology
#' # onto<-onto_process(HAO, Sharkey_2011[,1])
#' ## make shiny_in object
#' # shiny_in<<-make_shiny_in(onto)
#' ## run interactively to show only 50 characters
#' # runOntoFast(nchar=50, show.chars=T)
#' @export


onto_process<-function(ontology, name_characters, do.annot=TRUE, ...){
  id_characters<-paste("CHAR:", c(1:length(name_characters)), sep="")
  ontology$id_characters<-id_characters
  names(name_characters)<-id_characters
  ontology$name_characters<-name_characters

  if (do.annot){
 ontology$parsed_synonyms<-syn_extract(ontology)
 ontology$auto_annot_characters<-annot_all_chars(ontology, ...)
  }

 return(ontology)

}
sergeitarasov/ontoFAST documentation built on Nov. 1, 2017, 8:01 a.m.