version 0.2-1

DESCRIPTION

@@ -0,0 +1,19 @@
+Package: polySegratio
+Type: Package
+Title: Simulate and test marker dosage for dominant markers in
+        autopolyploids
+Version: 0.2-1
+Date: 2008-01-09
+Depends: gdata
+Author: Peter Baker
+Maintainer: Peter Baker <p.baker1@uq.edu.au>
+Description: Perform classic chi-squared tests and Ripol et al(1999)
+        binomial confidence interval approach for autopolyploid
+        dominant markers. Also, dominant markers may be generated for
+        families of offspring where either one or both of the parents
+        possess the marker. Missing values and misclassified markers
+        may be generated at random.
+License: GPL-2
+Packaged: 2009-11-17 16:23:49 UTC; pete
+Repository: CRAN
+Date/Publication: 2009-11-17 17:24:31

NAMESPACE

@@ -0,0 +1,3 @@
+export(addMisclass,addMissing,autoFill,expected.segRatio,makeLabel,plot.segRatio,plot.simAutoCross,plot.simAutoMarkers,print.segRatio,print.simAutoCross,print.simAutoMarkers,print.divideAutoMarkers,print.testSegRatio,segregationRatios,sim.autoCross,sim.autoMarkers,divide.autoMarkers,test.segRatio)
+#S3method(print, segRatio)
+#S3method(print, testSegRatio)

R/addMisclass.R

@@ -0,0 +1,134 @@
+`addMisclass` <-
+function(x, misclass=0, bands.missed=0, parents=FALSE, parent.cols=c(1,2), seed)
+{
+
+  ## Description: Adds missing data to objects of class autoMarker or
+  ## autoCross as specified.
+
+  ## Arguments:
+  ## x : object of class simAutoMarker or simAutoCross, or a matrix with
+  ##     dominant markers scored as 0 or 1 
+  ## misclass:      proportion misclassified specified as for na.proportion
+  ##                (Default: 0)
+  ## bands.missed: proportion of bands that are not scored when they are actually
+  ##               present. Note this is applied to correctly specified markers after
+  ##               markers are misclassified (Default: 0)
+  ## parents:      if TRUE then misclassify parental alleles, otherwise
+  ##               misclassify offspring marker alleles
+  ##               (Default: FALSE)
+  ## parent.cols: for object of simAutoClass the columns containg
+  ##              parental markers
+  ## seed:     random number generator (RNG) state for random number
+  ##           which will be set at start to reproduce results
+
+  ## Values:
+  ## x: returns object of class autoMarker or autoCross, or a matrix with
+  ##    dominant markers scored as 0 or 1 with extra components
+  ##    misclass.info: list with five elements
+  ##                proportion: numeric proportion misclassified
+  ##                index: indicates which markers were set as misclassified
+  ##                bands.proportion: numeric proportion of marker bands missed
+  ##                bands.index: indicates which markers bands were missed
+  ##                call: matches arguments when function called
+  ##                time.generated: time/date when misclassifieds added
+  ##                seed: seed for random number generation
+
+
+  if (!missing(seed)) {
+    set.seed(seed)
+  }
+
+  ## allow for simAutoMarkers, simAutoCross and matrix x
+
+  if (class(x) == "simAutoMarkers" | class(x) == "simAutoCross" ) {
+    if (class(x) == "simAutoMarkers") {
+      markers <- x$markers
+    } else {
+      if (parents) {
+        markers <- x$markers[,parent.cols]
+      } else {
+        markers <- x$markers[,-parent.cols]
+      }
+    }
+  } else {
+    if (is.matrix(x)) {
+      markers <- x
+    } else {
+      stop("x should be a matrix or of class simAutoMarkers or simAutoCross")
+    }
+  }
+
+  ## add in measurement error/misclassification if set
+
+  if (misclass != 0) {
+    if (misclass < 0 | misclass > 1)
+      stop("Error: 'misclass' should be between 0 and 1")
+    ## choose misclassified 
+    s <- sample( 1:length(markers), misclass*length(markers))
+    ## swap them
+    misclass.index <- cbind(row(markers)[s],col(markers)[s])
+    markers[misclass.index] <- (markers[misclass.index] == 0) + 0
+    misclass.info <- list(proportion=misclass, index=misclass.index)
+  } else {
+    misclass.info <- list(proportion=misclass)
+  }
+
+  ## add in bands.missed to markers correctly classified as 1's
+
+  if (bands.missed != 0) {
+    if (bands.missed < 0 | bands.missed > 1)
+      stop("Error: 'bands.missed' should be between 0 and 1")
+    m <- markers
+    m[misclass.index] <- 3
+    ok <- setdiff(1:length(markers),s)  # those elements not misclassified
+    index.ok <- cbind(row(markers)[ok],col(markers)[ok])
+    ones <- ok[markers[index.ok]==1]    # ok markers that re 1
+    ## choose bands.missed
+    sb <- sample( ones, bands.missed*length(ones))
+    bands.index <- cbind(row(markers)[sb],col(markers)[sb])
+    ## set them to zero
+    markers[bands.index] <- 0
+    misclass.info$bands.index <- bands.index
+    misclass.info$bands.proportion=bands.missed
+  } else {
+    misclass.info <- list(bands.proportion=bands.missed)
+  }
+
+
+  ## set up markers for simAutoMarkers or simAutoCross if necessary
+
+  if (class(x) == "simAutoMarkers" | class(x) == "simAutoCross") {
+    res <- x
+    if (class(x) == "simAutoMarkers") {
+      res$markers <- markers
+      res$seg.ratios <- segregationRatios(markers)
+      res$misclass.info <- misclass.info
+    } else {
+      parType <- rep( 1:3, times=x$no.parType)
+      if (parents) {
+        res$markers[,parent.cols] <- markers
+        res$p01$parent.markers <- markers[parType==1,]
+        res$p10$parent.markers <- markers[parType==2,]
+        res$p11$parent.markers <- markers[parType==3,]
+        res$parent.misclass.info <- misclass.info
+      } else {
+        res$markers[,-parent.cols] <- markers
+        res$p01$markers <- markers[parType==1,]
+        res$p10$markers <- markers[parType==2,]
+        res$p11$markers <- markers[parType==3,]
+        res$p10$seg.ratios <- segregationRatios(res$p10$markers)
+        res$p01$seg.ratios <- segregationRatios(res$p01$markers)
+        res$p11$seg.ratios <- segregationRatios(res$p11$markers)
+        res$misclass.info <- misclass.info
+      }
+    }
+    if (!missing(seed)) res$misclass.info$seed <- seed
+    res$misclass.info$call <- match.call()
+    res$misclass.info$time.generated <- date()
+
+  } else {
+    res <- markers
+  }
+  return(res)
+}
+

R/addMissing.R

@@ -0,0 +1,104 @@
+`addMissing` <-
+function(x, na.proportion=0, parent.cols=c(1,2), seed)
+{
+
+  ## Description: Adds missing data to objects of class autoMarker or
+  ## autoCross as specified.
+
+  ## Arguments:
+  ## x : object of class simAutoMarker or simAutoCross, or a matrix with
+  ##     dominant markers scored as 0 or 1 
+  ## na.proportion: proportion missing at random or a list
+  ##                with two components indiv and marker each containing
+  ##                c(prop. markers missing, prop. missing)
+  ##                (Default: 0)
+  ## parent.cols:  columns containing parental markers (etc) not altered
+  ##               only used if object of class simAutoCross
+  ## seed:     random number generator (RNG) state for random number
+  ##           which will be set at start to reproduce results
+
+  ## Values:
+  ## x: returns object of class autoMarker or autoCross, or a matrix with
+  ##    dominant markers scored as 0 or 1 with extra component na.proportion
+  ##    which has the following elements
+  ##    na.proportion: proportion missing at random or a list
+  ##                   with two components indiv and marker each containing
+  ##                   c(prop. markers missing, prop. missing)
+  ##    time.generated: time/date when data set generated + when missing added
+  ##    seed:  random number generator seed which could be used to
+  ##           reproduce results (I hope)
+  ##    call:  matches arguments when function called
+
+  if (!missing(seed)) {
+    set.seed(seed)
+  }
+
+  ## allow for simAutoMarkers, simAutoCross and matrix x
+
+  if (class(x) == "simAutoMarkers" | class(x) == "simAutoCross") {
+    if (class(x) == "simAutoMarkers") {
+      markers <- x$markers
+    } else {
+      markers <- x$markers[,-parent.cols]
+    }
+  } else {
+    if (is.matrix(x)) {
+      markers <- x
+    } else {
+      stop("x should be a matrix or of class simAutoMarkers or simAutoCross")
+    }
+  }
+  n.individuals <- ncol(markers)
+  n.markers <- nrow(markers)
+
+  ## drop markers if na.proportion set
+
+  if (mode(na.proportion) == "numeric") {
+    if (na.proportion != 0) {
+      if (na.proportion < 0 | na.proportion > 1)
+        stop("Error: na.proportion should be between 0 and 1")
+      ## choose missing and set to NA
+      s <- sample( 1:length(markers), na.proportion*length(markers))
+      markers[cbind(row(markers)[s],col(markers)[s])] <- NA
+    }
+  } else {
+    if (mode(na.proportion) == "list") {
+      s.rows <- sample( 1:n.markers , na.proportion$marker[1]*n.markers)
+      s.cols <- sample( 1:n.individuals , na.proportion$indiv[1]*n.individuals)
+      for (i in s.rows){
+        markers[i, sample(1:n.individuals,
+                          na.proportion$indiv[2]*n.individuals)] <- NA
+      }
+      for (i in s.cols){
+        markers[sample(1:n.markers,
+                       na.proportion$marker[2]*n.markers), i] <- NA
+      }
+    }
+  }
+
+  if (class(x) == "simAutoMarkers" | class(x) == "simAutoCross") {
+    res <- x
+    if (class(x) == "simAutoMarkers") {
+      res$markers <- markers
+      res$seg.ratios <- segregationRatios(markers)
+    } else {
+      res$markers[,-parent.cols] <- markers
+      res$seg.ratios <- segregationRatios(res$markers)
+      parType <- rep( 1:3, times=x$no.parType)
+      res$p10$markers <- markers[parType==1,]
+      res$p01$markers <- markers[parType==2,]
+      res$p11$markers <- markers[parType==3,]
+      res$p10$seg.ratios <- segregationRatios(res$p10$markers)
+      res$p01$seg.ratios <- segregationRatios(res$p01$markers)
+      res$p11$seg.ratios <- segregationRatios(res$p11$markers)
+    }
+    res$na.proportion <- list(na.proportion=na.proportion,
+                              time.generated <- date(),call=match.call())
+    if (!missing(seed)) res$na.proportion$seed <- seed
+  } else {
+    res <- markers
+  }
+
+  return(res)
+}
+

R/autoFill.R

@@ -0,0 +1,42 @@
+`autoFill` <-
+function(x, squash=FALSE)
+{
+  ## description: fill out blanks of a vector with preceeding label
+  ## eg. c("a","","","b","") becomes c("a","a","a","b","b")
+
+  ## Arguments:
+  ## x: data frame of two character vectors
+  ## squash: remove spaces from labels (default: TRUE)
+  ## NB: NO ERROR CHECKING SO BE CAREFUL
+
+  require("gdata")
+
+  ## set NA's to "" otherwise a problem
+  if (is.factor(x))
+    levels(x) <- c(levels(x),"")
+  x[is.na(x)] <- ""
+  ## and of course - what about leading/trailing spaces or just spaces...
+  if (is.factor(x)) {
+    levels(x) <- trim(levels(x))
+    } else {
+      x <- trim(x)
+    }
+
+  if (x[1] == "") cat("Warning: first value of vector is blank!\n")
+
+  for (i in 2:length(x)) {
+    if (x[i] == "")
+      x[i] <- x[i-1]
+  }
+
+  if (squash) {
+    if (is.factor(x)) {
+      levels(x) <- gsub(" ","",levels(x))
+      x <- factor(x)
+    }
+    if (is.character(x))
+      x <- gsub(" ","",x)
+  }
+  x
+}
+

R/divide.autoMarkers.R

@@ -0,0 +1,74 @@
+`divide.autoMarkers` <-
+function(markers, description=paste("Markers split for",
+                                      deparse(substitute(markers))),
+                              parent.cols=c(1,2), extra.cols = NULL,
+                              cols.drop = c(parent.cols,extra.cols))
+{
+
+  ## Function: divide.markers
+  ## Purpose: read markers (or more correctly dominant 1,0) marker data
+  ##          and return list object of containing markers data split
+  ##          according to parental alleles, namely 1,0 for each parent and
+  ##          1,1 for both parents
+  ##
+  ## Arguments:
+  ## 
+  ## markers:  matrix of 1, 0, NA indicating marker alleles
+  ##           rownames are markernames, column names are progeny names
+  ##           NB: If markers were simulated and stored as an object of
+  ##               class simAutoMarkers then  simAutoMarkers$markers
+  ##               may need to be split if parental markers misclassified
+  ## title:         to be used for printing/plotting
+  ## parent.cols:   column(s) for parental markers (default: 1,2)
+  ## extra.cols:    extra column(s) to be subsetted (default: NULL)
+  ## cols.drop:     columns to be dropped from markers
+  ##                before splitting data which
+  ##                can be set to NULL if no columns are to be dropped
+  ##                (Default: c(parent.cols,extra.cols)
+  ##
+  ## Values:
+  ##     p10, p01, p11  are lists for where the first, second
+  ##     are heterozygous for parents 1, 2 and both resp. Each list contains
+  ## description:  text containing a description for printing
+  ## parent:       label for parent
+  ## markers:      markers for specified parental type (including parents etc)
+  ## extras:       extra column subsetted if specified
+  ## seg.ratios:   segregation ratios as class segRatios
+
+  ## index to subset appropriate markers
+  index.p10 <- markers[,parent.cols[1]]==1 & markers[,parent.cols[2]]==0
+  index.p01 <- markers[,parent.cols[1]]==0 & markers[,parent.cols[2]]==1
+  index.p11 <- markers[,parent.cols[1]]==1 & markers[,parent.cols[2]]==1
+
+  ## produce lists
+  parent1 <- colnames(markers)[parent.cols[1]]
+  parent2 <- colnames(markers)[parent.cols[2]]
+  descp <- paste("Parent with 1 is", parent1,"and 0 is",parent2)
+  p10 <- list(description=descp, parent.inherited=parent1,
+              markers=markers[index.p10,-cols.drop],
+              seg.ratios=segregationRatios(markers[index.p10,-cols.drop]))
+
+  descp <- paste("Parent with 0 is", parent1,"and 1 is",parent2)
+  p01 <- list(description=descp, parent.inherited=parent2,
+              markers=markers[index.p01,-cols.drop],
+              seg.ratios=segregationRatios(markers[index.p01,-cols.drop]))
+
+  parent <- paste(parent1,parent2,sep=" & ")
+  descp <- paste("Parents both  with 1 -", parent)
+  p11 <- list(description=descp, parent.inherited=parent,
+                   markers=markers[index.p11,-cols.drop],
+              seg.ratios=segregationRatios(markers[index.p11,-cols.drop]))
+
+  if (length(extra.cols) > 0) {
+    p10$extras <- markers[index.p10, extra.cols]
+    p01$extras <- markers[index.p01, extra.cols]
+    p11$extras <- markers[index.p11, extra.cols]
+  }
+
+  ## return result
+  res <- list(description=description, p10=p10, p01=p01,
+              p11=p11, time.split=date(), call=match.call())
+  oldClass(res) <- "divideAutoMarkers"
+  return(res)
+}
+