R/MareyMap.Methods.R

In aursiber/MareyMap: Estimation of Meiotic Recombination Rates Using Marey Maps

# Copyright 2006 Laboratoire de Biologie et de Biometrie Appliquée 
# (UMR 5558);CNRS; Univ. Lyon 1, 43 bd 11 nov, 69622, 
# Villeurbanne Cedex, France.
#
# This file is part of MareyMap.
#
# MareyMap is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# MareyMap is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with MareyMap; if not, write to the Free Software
# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA



#--- constructors
setMethod("MareyMap", signature(data_table = "missing", column_names = "missing", set_name = "missing", map_name = "missing"), function() {
  new("MareyMap")
})


setMethod("MareyMap", signature(data_table = "data.frame"), function(data_table, column_names = list(name = "name", phys = "phys", gen = "gen", vld = "vld"), set_name = "", map_name = "") {
  object <- new("MareyMap")
  object@setName <- set_name
  object@mapName <- map_name
  object@markerNames <- as.vector(data_table[[column_names$name]])
  object@physicalPositions <- as.vector(data_table[[column_names$phys]])
  object@geneticDistances <- as.vector(data_table[[column_names$gen]])
  object@markerValidity <- as.vector(data_table[[column_names$vld]])
  object
})

  
#--- accessors
setMethod("setName", "MareyMap", function(object) object@setName)
setMethod("mapName", "MareyMap", function(object) object@mapName)
setMethod("markerNames", "MareyMap", function(object) object@markerNames)
setMethod("physicalPositions", "MareyMap", function(object) object@physicalPositions)
setMethod("geneticDistances", "MareyMap", function(object) object@geneticDistances)
setMethod("interpolations", "MareyMap", function(object) object@interpolations)
setMethod("markerValidity", "MareyMap", function(object) object@markerValidity)    


#--- replace methods
setReplaceMethod("physicalPositions", "MareyMap", function(object, value) {
  object@physicalPositions <- value
  object
})


setReplaceMethod("geneticDistances", "MareyMap", function(object, value) {
  object@geneticDistances <- value
  object
})


setReplaceMethod("markerNames", "MareyMap", function(object, value) {
  object@markerNames <- value
  object
})


setReplaceMethod("setName", "MareyMap", function(object, value) {
  object@setName <- value
  object
})


setReplaceMethod("mapName", "MareyMap", function(object, value) {
  object@mapName <- value
  object
})


setReplaceMethod("interpolations", "MareyMap", function(object, value) {
  object@interpolations <- value
  object
})


setReplaceMethod("markerValidity", "MareyMap", function(object, value) {
  object@markerValidity <- value
  object
})


#--- interpolationNames
setGeneric("interpolationNames", function(object, set_name, map_name) standardGeneric("interpolationNames"))


#--- interpolation
setMethod("interpolation", c("MareyMap", "character"), function(object, inter_name) {
  inter <- object@interpolations
  inter[match(inter_name, lapply(inter, function(x){name(x)}))][[1]]
})


#--- interpolation<-
setMethod("interpolation<-", c("MareyMap", "character", "Interpolation"), function(object, inter_name, value) {
  object@interpolations[match(inter_name, lapply(object@interpolations, function(x) {name(x)}))][[1]] <- value
  object
})


setMethod("+", c(e1 = "MareyMap", e2 = "Interpolation"), function(e1, e2) {
  e2 <- interpolate(e2, e1)
  e1@interpolations[[name(e2)]] <- e2
  e1
})


#---
setMethod("validPositions", "MareyMap", function(object) {
  physicalPositions(object)[which(markerValidity(object))]
})


#--- plot
setMethod("plot", signature(x = "MareyMap", y = "missing"), function(x , y,...) {
  cl <- match.call()
  cl$object <- cl$x
  cl$x <- NULL
  
	#split the screen and draw both                
  lo <- layout(matrix(c(1, 2), 2), heights = c(2, 1))
  layout.show(lo)
  
  if(is.null(cl$model) || cl$model) {
    cl[[1]] <- as.name("plotModels")
    par(mar = c(4, 5, 1, 1) + 0.1)
    if(is.null(cl$markers) || cl$markers) {
			# don't draw axis if the map is to be drawn as well
      cl$xaxt <- "n"
      cl$yaxt <- "n"
      cl$ylab <- ""        
      cl$xlab <- ""
    }
    eval(cl)
  }
  
  if(is.null(cl$markers) || cl$markers) {
    par(new = TRUE)
    cl[[1]] <- as.name("plotMarkers")
    cl$xaxt <- NULL
    cl$yaxt <- NULL
    cl$xlab <- NULL
    cl$ylab <- NULL
    cl$ylim <- NULL
    eval(cl)
	  cl[[1]] <- as.name("plotRates")
	  eval(cl)
  }
})

  
#--- plotMarkers
setMethod("plotMarkers", "MareyMap", function(object, ...) {
  par(mar = c(4, 5, 1, 1) + 0.1)
  cl <- match.call()
  if(is.null(cl$xlab))
    cl$xlab <- "Physical positions (Mb)" 
  if(is.null(cl$ylab))
    cl$ylab <- "Genetic distances (cM)"
  plot(object@physicalPositions / 1000000, object@geneticDistances, xlab = cl$xlab, ylab = cl$ylab, ...)
  if(length(which(!markerValidity(object))) != 0)
    points(physicalPositions(object)[which(!markerValidity(object))] / 1000000, geneticDistances(object)[which(!markerValidity(object))], col = "red", pch = 3, type = "p")
})


#--- plotModels
setMethod("plotModels", "MareyMap", function(object, ...) {
  par(mar = c(4, 5, 1, 1) + 0.1)
  cl <- match.call()
  if(is.null(cl$ylim))
    cl$ylim <- c(0, max(geneticDistances(object), na.rm = TRUE))
  if(is.null(cl$xlim))
    cl$xlim <- c(0, max(physicalPositions(object) / 1000000, na.rm = TRUE))
  if(is.null(cl$xlab))
    cl$xlab <- "Physical positions (Mb)"
  if(is.null(cl$ylab))    
    cl$ylab <- "Genetic distances (cM)"
  plot(-1, -1, xlab = cl$xlab, ylab = cl$ylab, col = "white", xaxt = "n", yaxt = "n")
  cl$xaxt <- "n"
  cl$yaxt <- "n"
  cl$xlab <- ""
  cl$ylab <- ""
  cl$col <- NULL
  cl$x <- NULL
  cl$y <- NULL
  cl[[1]] <- as.name("plotModel")
  lapply(interpolations(object), function(itr) {
    if(visible(itr)) {
      par(new = TRUE)
      cl$object <- itr
      eval(cl)
    }
  })
  return()
})


#--- plotRates
setMethod("plotRates", "MareyMap", function(object, ...) {
  cl <- match.call()
  par(mar = c(4, 5, 1, 1) + 0.1)
  if(length(object@interpolations) == 0) {
    par(col = "white", col.lab = "white", col.axis = "white", tck = 0)
    plot(0, 0)
  } else {
    if(is.null(cl$xlim))
      cl$xlim <- c(0, max(physicalPositions(object) / 1000000, na.rm = T))
    if(is.null(cl$ylim))
      cl$ylim <- c(0, max(unlist(lapply(object@interpolations, function(itr) {max(rates(itr), na.rm = TRUE)}))) + 1)
    if(is.null(cl$xlab))
      cl$xlab <- "Physical positions (Mb)"
    if(is.null(cl$ylab))
      cl$ylab <- "Recomb. rates \n (cM/Mb)"
		## setting up axis
    plot(0, 0, xlab = cl$xlab, ylab = cl$ylab, xlim = cl$xlim, ylim = cl$ylim, col = "white")
    
    cl$xaxt <- "n"
    cl$yaxt <- "n"
    cl$ylab <- ""        
    cl$xlab <- ""
    cl[[1]] <- as.name("plotRate")
    lapply(interpolations(object), function(itr) {
      if(visible(itr)) {
        par(new = TRUE)
        cl$object <- itr
        eval(cl)
      }
    })
  }
})


#--- '[' operator
setMethod("[", "MareyMap", function(x, i, j, ..., drop) {
  c(name = x@markerNames[i], phys = x@physicalPositions[i], gen = x@geneticDistances[i])
})


#--- '[[' operator
setMethod("[[", "MareyMap", function(x, i, j, ..., drop) {
  lst <- list(x@physicalPositions[[i]], x@geneticDistances[[i]], x@markerValidity[[i]])
  lst <- c(x@markerNames[[i]], lst)
  names(lst) <- c("name", "phys", "gen", "valid")
  lst
})


#--- '[[<-' operator
setMethod("[[<-", "MareyMap", function(x, i, j, ..., drop, value) {
  x@markerNames[[i]] <- value[["name"]]
  x@physicalPositions[[i]] <- value[["phys"]] 
  x@geneticDistances[[i]] <- value[["gen"]]
  x@markerValidity[[i]] <- value[["valid"]]
  for(itr in interpolations(x)) {
    interpolate(itr, x)
    x <- x + itr
  }
  x
})


# as MareyMap --> data.frame
setAs("MareyMap", "data.frame", function(from, to) {
  df <- data.frame(from@markerNames, from@physicalPositions, from@geneticDistances, from@markerValidity)
  df <- cbind(from@setName, from@mapName, df)
  names <- c("set", "map", "mkr", "phys", "gen", "vld")
  lapply(interpolations(from), function(itr) {        
    if(persistent(itr)) {
      df <<- cbind(df, rates(itr))
      names <<- c(names, name(itr))    
    }
  })
  names(df) <- names
  df
})


# as data.frame --> MareyMap
setAs("data.frame", "MareyMap", function(from, to) {
  object <- new("MareyMap")
  mapName(object) <- as.character(as.vector(from$map)[[1]])
  setName(object) <- as.character(as.vector(from$set)[[1]])
  markerNames(object) <- as.character(as.vector(from$mkr))
  geneticDistances(object) <- from$gen
  physicalPositions(object) <- from$phys
  if("vld" %in% names(from))
    markerValidity(object) <- as.vector(from$vld)
  else
    markerValidity(object) <- rep(TRUE, nrow(from)) 
  object
})


setMethod("removeMarker", c("MareyMap", "integer"), function(object, value) {
  if((value > length(object@markerNames)) || (value <= 0))
    return(object)
  df <- as(object, "data.frame")
  itrs <- interpolations(object)
  if (value == 1)
    object <- as(df[2:nrow(df), ], "MareyMap")
  if (value == nrow(df))
    object <- as(df[1:(nrow(df) - 1), ], "MareyMap")
  if(value > 1 && value < nrow(df))
    object <- as(rbind(df[1:(value - 1), ], df[(value + 1):nrow(df), ]), "MareyMap")
  for (itr in itrs) {
    object <- object + itr
  }
  object
})


setMethod("textFile", c("MareyMap", "character"), function(object, file) {
  df <- as(object, "data.frame")
  itrcreate <- ""
  lapply(interpolations(object), function(itr) {
    if(persistent(itr))
      itrcreate <<- paste(itrcreate, "#", setName(object), " - ", mapName(object) ," - ", name(itr), ":", createOrder(itr), "\n", sep = "")
  })
  write(itrcreate, file = as.character(file))
  write.table(t(as.vector(colnames(df))), file = as.character(file), col.names = FALSE, row.names = FALSE, append = TRUE)
  write.table(df, file = as.character(file), col.names = FALSE, row.names = FALSE, append = TRUE)
})


setMethod("query", c("MareyMap", "numeric"), function(object, pos) {
  sapply(interpolations(object), function(itr) {query(itr, pos)})
})


setAs("MareyMap", "NULL", function(from, to) {NULL})