.packageName <- "mvngGrAd"
#line 1 "/private/tmp/RtmpNjmlDv/R.INSTALL10d63af1/mvngGrAd/R/movG-class.R"
setClass("movG",
         representation(movingMeanMap = "matrix",
                        row = "integer",
                        col = "integer",
                        observedPhe = "numeric",
                        adjustedPhe = "numeric",
                        movingMean = "numeric",
                        nValues = "integer",
                        adjModel = "lm",
                        correlation = "numeric",
                        maxValues = "integer",
                        FunCall = "call"))
#line 1 "/private/tmp/RtmpNjmlDv/R.INSTALL10d63af1/mvngGrAd/R/circularExtension.R"
circularExtension <- function(i,
                               j,
                               layers,
                               rowLimit,
                               colLimit){
  ## validity checks:

  ## 1. if any of the layers is present more than once in the the
  ## argument to layers, "stop" and issue an error message.

  if(any(duplicated(layers)))
    {
      stop(paste("\nWrong actual argument to formal argument 'layers':\n",
                 "Each layer must only appear once!\n\n"))
    }

  ## 2. if layers is not NULL but a "0" appears in the vector, stop
  ## and issue an error message

  if(0%in%layers)
    {
      stop(paste("\nWrong actual argument to formal argument 'layers':\n",
                 "'layers' can either be 'NULL' (no circular layer at all) or a vector\n",
                 " with the layers given as integers, without any '0'!.\n\n")) 
    }

  ## 3. stop if any of layers < 1

  if(any(layers < 1))
    {
      stop(paste("\n\nWrong actual argument to formal argument 'layers':\n",
                 "There must be no negative layers!\n\n"))
    }
  
  ## 4. stop if any of the subscripts i and j exceed the row
  ## resp. col.limit or are smaller than 1

  if((as.integer(i) > as.integer(rowLimit)) |
     (as.integer(i) < 1) |
     (as.integer(j) > as.integer(colLimit)) |
     (as.integer(j) < 1))
    {
      stop(paste("\nArguments to 'i' and 'j' must be within 1:rowLimit resp.\n",
                 "1:colLimit\n\n"))
    }

  diagSubscripts <- matrix(nrow=0,ncol=2)

  ## if layers = NULL, do nothing and return an empty matrix

  if(is.null(layers))
    {
      return(diagSubscripts)
    }

  else
    {
      for(n in layers)
        {
          ## i starts at zero o'clock as i - n and rises in
          ## steps of 1 to i + n at six o'clock (excluding the
          ## i of the center).
          ## 
          zeroToSix <- c((i-n):(i-1),
                         (i+1):(i+n))
          ## Then at six o'clock i falls from i + n in steps
          ## of 1 to i-n at zero o'clock (exluding the i of the
          ## center). This is simply the opposite of zeroToSix.
          sixToZero <- zeroToSix[length(zeroToSix):1]
          ##
          wholeI <- c(zeroToSix,sixToZero)
          ##
          ## j starts at nine o'clock as j - n and rises in
          ## steps of 1 to j + n at three o'clock (excluding
          ## the j of the center).
          ## 
          nineToThree <- c((j-n):(j-1),
                           (j+1):(j+n))
          ## Then at three o'clock j falls from j + n in
          ## steps of 1 to j-n at nine o'clock (exluding the
          ## j of the center). This is simply the opposite
          ## of nineToThree.
          threeToNine <- nineToThree[length(nineToThree):1]
          ##
          wholeJ <- c(nineToThree, threeToNine)
          ##
          ## wholeJ still needs to be tuned with wholeI so
          ## that it to goes from zero to zero o'clock 
          wholeJ <- wholeJ[c(n+1:(length(wholeJ)-n),1:n)]
          ##
          ## Prevention of indexing when subscript out of
          ## bounds: if the subscript in wholeI is < i, it
          ## means that it goes up toward row = 1. Therefore
          ## it must not be smaller than 1. If the subscript
          ## is > i, it means that it goes down toward row =
          ## rowLimit so it must not be larger.
          ##
          wrongI <- which((wholeI < 1)
                          | (wholeI > rowLimit))
          ## if one is TRUE, subscripting is prevented by
          ## setting i and the corresponding j to NULL.
          wholeI[wrongI] <- is.null(wholeI[wrongI])
          wholeJ[wrongI] <- is.null(wholeJ[wrongI])
          ##
          ## The same for wholeJ, just that the subscript
          ## must not be smaller than 1 or larger than
          ## colLimit. Subscripts already set to NULL
          ## are not tested again.
          ##
          wrongJ <- which(!(is.null(wholeJ))
                          & (wholeJ < 1)
                          |(wholeJ > colLimit))               
          ##
          wholeJ[wrongJ] <- is.null(wholeJ[wrongJ])
          wholeI[wrongJ] <- is.null(wholeI[wrongJ])
          ##
          diagSubscripts <- rbind(diagSubscripts,
                                  cbind(wholeI, wholeJ))
        } ## end n
      diagSubscripts <- diagSubscripts[which(diagSubscripts[,1] != 0),,drop=FALSE]
      return(diagSubscripts)
    }
} ## end of function


#line 1 "/private/tmp/RtmpNjmlDv/R.INSTALL10d63af1/mvngGrAd/R/entryData.R"
setGeneric("entryData",
           def = function(object,
             ...)
           {
             standardGeneric("entryData")
           }
           )

#line 1 "/private/tmp/RtmpNjmlDv/R.INSTALL10d63af1/mvngGrAd/R/entryDataMethods.R"
setMethod("entryData",
          signature(object = "movG"),
          function(object,...)
          {
            return(round(data.frame(row = object@row,
                              column = object@col,
                              adjustedPhe = object@adjustedPhe,
                              observedPhe = object@observedPhe,
                              movingMean = object@movingMean,
                              nValues = object@nValues),2))
          }
           ) 


#line 1 "/private/tmp/RtmpNjmlDv/R.INSTALL10d63af1/mvngGrAd/R/extendHorVer.R"
extendHorVer <- function(i,
                          j,
                          shapeCross,
                          rowLimit,
                          colLimit)
   {
     ## Validity checks:
     ## 1. if shapeCross is not a list of length 4, stop and issue an error message

     if(!(is.list(shapeCross) && identical(length(shapeCross),as.integer(4))))
       {
         stop(paste("Wrong actual argument to formal argument 'shapeCross':\n",
                    "'shapeCross' must be a list of length 4!\n\n"))
       }
     ## 2. if there are duplications in the elements
     ## of the argument to shapeCross stop and issue an error message.

     anyDup <- sapply(shapeCross,duplicated)

     if(any(sapply(anyDup,any)))
       {
         stop(paste("\nWrong actual argument to formal argument 'shapeCross':\n",
                    "There must be no duplications within the elements of 'shapeCross'!\n\n"))
       }

     ## 3. if there are any '0' in any of the elements to shapeCross,
     ## stop and issue a error message.

     if(0%in%unlist(shapeCross))
       {
         stop(paste("\n\nWrong actual argument to formal argument 'shapeCross':\n",
                    "The elements of 'shapeCross' can either be NULL (no cells included\n",
                    "in this direction) or a vector of integer values, without any '0'.\n\n"))

       }
     ## 4. stop if any of shapeCross < 1

     if(any(unlist(shapeCross) < 1))
       {
         stop(paste("\n\nWrong actual argument to formal argument 'shapeCross':\n",
              "The elements of 'shapeCross' must not be negative!\n\n"))
       }
     ## 5. stop if any of the subscripts i and j exceed the row
     ## resp. col.limit or are smaller than 1

     if((as.integer(i) > as.integer(rowLimit)) |
        (as.integer(i) < 1) |
        (as.integer(j) > as.integer(colLimit)) |
        (as.integer(j) < 1))
       {
         stop(paste("\nArguments to 'i' and 'j' must be within 1:rowLimit resp.\n",
                    "1:colLimit\n\n"))
       }


     ## Horizontal: for each value in shapeCross
     ## (l) go i-l up respective i+1 down. j
     ## remains the same since the column
     ## doesn't change. Test whether the row
     ## subscript gets out of bounds, if so,
     ## both the row and column subscript
     ## remain NULL. This makes sure that no
     ## subscripting takes place latter
     ## on. To be sure and to save space,
     ## remove NULL subscripts at the end. 
     ## If the value given for shapeCross is NULL,
     ## don't do anything.
     ## Vertical: principally the same, just
     ## that j changes towards right or left
     ## and i remains constant.
     includedDown <- matrix(0,nrow=length(shapeCross[[1]]),
                            ncol=2)     
     pos <- 1
     if(!is.null(shapeCross[[1]]))
       {
         for(l in shapeCross[[1]])
           {
             if(i+l <= rowLimit)
               {
                 includedDown[pos,] <-
                   c(i+l,j)
               }
             pos <- pos + 1
           } ## end l
       }
     
     includedUp <- matrix(0,nrow=length(shapeCross[[2]]),
                          ncol=2)
     ##
     pos <- 1
     if(!is.null(shapeCross[[2]]))
       {
         for(l in shapeCross[[2]])
           {
             if(i-l >= 1)
               {
                 includedUp[pos,] <-
                   c(i-l,j)
               }
             pos <- pos + 1
           } ## end l
       }
     ## j + l > colLimit, NULL
     ## i - l < 1, NULL

     includedLeft <- matrix(0,nrow= length(shapeCross[[3]]),
                            ncol=2)
     pos <- 1
     if(!is.null(shapeCross[[3]]))
       {
         for(l in shapeCross[[3]])
           {
     
             if(j - l >= 1)
               {
                 includedLeft[pos,] <-
                   c(i, j - l)
               }
             pos <- pos + 1
           } ## end l
       }
     
     includedRight <- matrix(0,nrow=length(shapeCross[[4]]),
                             ncol=2)
     pos <- 1
     if(!is.null(shapeCross[[4]]))
       {
         for(l in shapeCross[[4]])
           {
     
             if(j + l <= colLimit)
               {
                 includedRight[pos,] <- 
                   c(i,j + l)
               }
             pos <- pos + 1
           } ## end
       }
     verHor <- rbind(includedDown,
                     includedUp,
                     includedLeft,
                     includedRight)
     verHor <- verHor[which(verHor[,1] != 0),,drop=FALSE]     
     return(verHor)
   } ## end of function
#line 1 "/private/tmp/RtmpNjmlDv/R.INSTALL10d63af1/mvngGrAd/R/fittedMethods.R"
setGeneric("fitted")
setMethod("fitted",
          "movG",
          function(object,...)
          {
            return(object@adjustedPhe)
          }
          )
#line 1 "/private/tmp/RtmpNjmlDv/R.INSTALL10d63af1/mvngGrAd/R/movingGrid.R"
movingGrid <- function(rows,
                       columns,
                       obsPhe,
                       shapeCross,
                       layers,
                       excludeCenter = TRUE)
  {
    FUNcall <- list(quote(movingGrid),
                    rows = rows,
                    columns = columns,
                    obsPhe = obsPhe,
                    shapeCross = shapeCross,
                    layers = layers,
                    excludeCenter = excludeCenter)
    
    FUNcall <- as.call(FUNcall)
    
    ## maximum possible number of values, given the choosen design
    
    plusCenter <- 0
    
    if(identical(excludeCenter,FALSE))
      {
        plusCenter <- 1
      }
    
    maxValues <- sum(length(unlist(shapeCross)), ## cross
                      sum(layers*4),         ## circular layers
                      plusCenter)

     ## validity checks
##################

     ## 1. stop if the grid contains no values

     if(identical(as.integer(maxValues), as.integer(0)))
       {
         stop(paste("\nThe grid must consist of at least one value (cell)!\n\n"))
       }

     ## 2. give a warning if the grid consists only of the center cell

     if(identical(as.integer(maxValues), as.integer(1)) &&
        identical(excludeCenter,FALSE))
       {
         warning(paste("\nThe grid consisted only of the center cell. This makes\n",
                       "no sense and the adjusted values will give no information at all!\n\n"))
       }
    

     ## calculate the row and column limits of the    
     ## field map:
    
     rowLimit <- max(rows)
     colLimit <- max(columns)

     ## bring the row and col subscripts and the
     ## obsPhe into one matrix
     rowCol <- cbind(rows,columns,obsPhe)
     ##
     ## empty matrix with max(rowCol[,1]) rows and
     ## max(rowCol[,2]), columns
     ##
     fieldMap <- matrix(nrow = rowLimit,
                        ncol = colLimit)
     ##
     ## fill the matrix with rowCol[,3] by
     ## indexing via the rowCol[,1:2] matrix.
     ##
     fieldMap[rowCol[,1:2]] <- rowCol[,3]
     ##
    
     ## to store the moving means
     movingMeanMap <- matrix(nrow = rowLimit,
                             ncol = colLimit)

     ## and the number of included (non NA) values

     nValuesMap <- matrix(nrow = rowLimit,
                          ncol = colLimit)

     
                          
     for(i in 1:rowLimit) ## rows
       {
         for(j in 1:colLimit) ## columns
           {
             ## coordinates of the cells in the "cross"
             
             coordCross <- extendHorVer(i = i,
                                        j = j,
                                        shapeCross = shapeCross,
                                        rowLimit = rowLimit,
                                        colLimit = colLimit)

             ## coordinates of the cells in the circular layers

             coordCirc <- circularExtension(i = i,
                                            j = j,
                                            layers = layers,
                                            rowLimit = rowLimit,
                                            colLimit = colLimit)

             ## coordinates of all the cells in the grid:

             ## excluding the center:

             if(identical(excludeCenter,FALSE))
               {
                 coordGrid <- rbind(cbind(i,j),
                                    coordCross,
                                    coordCirc)
               }

             else
               {
                 coordGrid <- rbind(coordCross,
                                    coordCirc)
               }
             

             ## nValues
             nValuesMap[i,j] <-
               sum(!is.na(fieldMap[coordGrid[,1:2,drop = FALSE]]))
             

             ## moving mean calculation ########
             ## ################################

             ## To prevent the occurence of NaNs, calculate the mean
             ## only if there is at least one non-NA value, else set
             ## the moving Mean to NA
             
             if(sum(!is.na(fieldMap[coordGrid[,1:2,drop = FALSE]])) > 0)
               {
                 movingMeanMap[i,j] <-
                   mean(fieldMap[coordGrid[,1:2,drop = FALSE]],
                        na.rm = TRUE)
               }
             
             else
               {
                 movingMeanMap[i,j] <- NA
               }

           } ## end j
             
       } ## end i
     


     ## adjustment procedure ##
     ## #################### ##

     ## 1. create a vector with the moving mean results that,
     ## corresponds to row, column and obsPhe

     movingMeans <- movingMeanMap[rowCol[,1:2,drop = FALSE]]

     ## and for the nValues

     nValues <- nValuesMap[rowCol[,1:2,drop = FALSE]]

     ## 2. calculate the coefficient of the regression of
     ## the moving means on the phenotypic values
     
     model <- lm(rowCol[,3] ~ movingMeans,
                 na.action = "na.exclude")

     coefAdj <- model$coefficients[2]

     names(coefAdj) <- NULL

     ## 3. calculate the adjusted phe. values
     
     adjPhe <-
       rowCol[,3] -
         (coefAdj*(movingMeans - mean(movingMeans,na.rm = TRUE)))

     adjPhe <- round(adjPhe,3)

     ## 4. calculate the correlation between the moving means
     ## and the phenot. values

     correlation <-
       cor(rowCol[,3],movingMeans, use = "complete.obs")


### give a warning and suggestions when moving means could not be
### calculated for all entries

     if(any(is.na(movingMeans)))
       {
         warning(paste("\n\nMoving means could not be calculated for all entries\n",
                       "because no non-NA values were available.\n",
                       "A solution is to change or enlarge the design of the grid.\n\n"))
       }

    
     result <- new("movG",
                   movingMeanMap = movingMeanMap,
                   row = as.integer(rowCol[,1]),
                   col = as.integer(rowCol[,2]),
                   observedPhe = rowCol[,3],
                   adjustedPhe = adjPhe,
                   movingMean = movingMeans,
                   nValues = nValues,
                   adjModel = model,
                   correlation = correlation,
                   maxValues = as.integer(maxValues),
                   FunCall = FUNcall)
     
     return(result)

  }
#line 1 "/private/tmp/RtmpNjmlDv/R.INSTALL10d63af1/mvngGrAd/R/movingMean.R"
setGeneric("movingMean",
           def = function(object,
             ...)
           {
             standardGeneric("movingMean")
           }
           )

#line 1 "/private/tmp/RtmpNjmlDv/R.INSTALL10d63af1/mvngGrAd/R/residualsMethods.R"
setGeneric("residuals")
setMethod("residuals",
           "movG",
          function(object,...)
          {
            object <- object@adjModel

            callGeneric(object)
          })
#line 1 "/private/tmp/RtmpNjmlDv/R.INSTALL10d63af1/mvngGrAd/R/showMethods.R"
setMethod("show",
          signature(object = "movG"),
          function(object)
          {
            sumRes <- list(FunCall= object@FunCall[[1]],
                           maxValues = object@maxValues,
                           meanNumValues =  mean(object@nValues),
                           nObs = length(object@observedPhe),
                           nNAvalues = sum(is.na(object@observedPhe)),
                           correlation = object@correlation,
                           regCoef = coef(object@adjModel)[2],
                           dimFieldMap = c(nrow= max(object@row),
                             ncol = max(object@col)))
            ##
            cat("\nAdjustment by function:" ,sumRes$FunCall, "\n")
            cat("\nMaximum possible number of values in the grid:", sumRes$maxValues,"\n")
            cat("\nMean number of values in grid:", round(sumRes$meanNumValues,2),"\n")
            cat("\nNumber of observation:", sumRes$nObs,", number of NA-observations:",
                sumRes$nNA,"\n")
            cat("\nCoefficient of correlation between moving means\nand observed phe. values:",
                round(sumRes$correlation,2),"\n")
            cat("\nRegression coefficient of moving means regressed\non observed phe. values :",
                round(sumRes$regCoef,2),"\n")
            cat("\nExperimental layout:\n",
                "\trows:", sumRes$dimField[1],"\n\tcolumns:",sumRes$dimField[2],"\n" )
          }
          )


#line 1 "/private/tmp/RtmpNjmlDv/R.INSTALL10d63af1/mvngGrAd/R/sketchGrid.R"
setGeneric("sketchGrid",
           def = function(
             i,
             j,
             rowLimit,
             colLimit,
             layers,
             shapeCross,
             excludeCenter,
             ...)
           {
             standardGeneric("sketchGrid")
           }
           )
#line 1 "/private/tmp/RtmpNjmlDv/R.INSTALL10d63af1/mvngGrAd/R/sketchGridMethods.R"
setMethod("sketchGrid",
          signature(                    
                    layers = "ANY",                                        
                    shapeCross = "ANY"),
          function(i,
                   j,
                   rowLimit,
                   colLimit,
                   layers,
                   shapeCross,
                   excludeCenter,
                   ...)
          {
### used for designed grid
            coordCross <- extendHorVer(i = i,
                                       j = j,
                                       shapeCross = shapeCross,
                                       rowLimit = rowLimit,
                                       colLimit = colLimit)
            ##
            coordCirc <- circularExtension(i = i,
                                           j = j,
                                           layers = layers,
                                           rowLimit = rowLimit,
                                           colLimit = colLimit)
            ##
            if(identical(excludeCenter,FALSE))
              {
                coordGrid <- rbind(cbind(i,j),
                                   coordCross,
                                   coordCirc)
              }
            ##
            else
              {
                coordGrid <- rbind(coordCross,
                                   coordCirc)
              }
            ##
            plot.new()
            plot.window(xlim = c(0,colLimit),
                        ylim = c(0,rowLimit))
            ##
            axis(2,at=1:rowLimit,
                 labels=rowLimit:1,
                 cex.axis=0.5)
            ##
            axis(1,at=1:colLimit,
                 labels=1:colLimit,
                 cex.axis=0.5)
            ##
            ##
            mtext("column",
                  1,
                  line = 3,
                  font = 2)
            ##
            mtext("row",
                  2,
                  line = 3,
                  font = 2)
            ##
            ## empty cells
            ##
            points(x = rep(1:colLimit,rowLimit),
                   y = (rowLimit+1)- rep(1:rowLimit, each = colLimit))
            ##
            ## color cells that are included in the grid
            ##
            points(x = coordGrid[,2],
                   y = (rowLimit + 1)-coordGrid[,1],
                   pch = 21, bg = "black")
            ##
          } ## end if definition
          ) 




#line 1 "/private/tmp/RtmpNjmlDv/R.INSTALL10d63af1/mvngGrAd/R/summaryMethods.R"
setGeneric("summary")
setMethod("summary",
          signature(object = "movG"),
          function(object,showSummary = TRUE)
          {
            sumRes <- list(FunCall= object@FunCall[[1]],
                           maxValues = object@maxValues,
                           meanNumValues =  mean(object@nValues),
                           nObs = length(object@observedPhe),
                           nNAvalues = sum(is.na(object@observedPhe)),
                           correlation = object@correlation,
                           regCoef = coef(object@adjModel)[2],
                           dimFieldMap = c(nrow= max(object@row),
                             ncol = max(object@col)))

            if(identical(showSummary, TRUE))
              {
                show(object)
              }
            return(invisible(sumRes))
}
)















#line 1 "/private/tmp/RtmpNjmlDv/R.INSTALL10d63af1/mvngGrAd/R/movingMeanMethods.R"
setMethod("movingMean",
          signature(object = "movG"),
          function(object,...)
          {
            return(object@movingMean)
          }
          )


