############################################################
## Additional File 1 
##
## This script contains all functions used in the paper that 
## are not avaliable in beadarray.
## It is designed to be loaded as part of Additional File 2,
## but all functions should work independently
#############################################################

###############################
## Functions used in multiple plots
####################################

matrixCoords <- function(index, nrow) {
  return(c(index %% nrow, (index %/% nrow)+1))
}

proximalBeads <- function(coords, text, dist = 8) {    
    idx <- which( (abs(text[,3] - coords[2]) < dist) & (abs(text[,4] - coords[1]) < dist) );
    return(idx)
}

neighboursMatrixForAll <- function(nsegs = 9, ncols = 397, nrows = 326) {
## calculate the neighbours matrix assuming 
## all points in the grid are filled
## default values are for Expression Arrays at the moment
    polaritydown<-T
    NN<-matrix(NA,nrow=nsegs*nrows*ncols, ncol=6)
    i<-0
    storepolaritydown<-polaritydown
    for(segment in 1:nsegs){
        cat(segment,"\n")
        for(col in 1:ncols){
            for(bead in 1:nrows){
                i<-i+1

                temp<-NULL
                if(bead>1){temp<-c(temp,i-1)}
                if(bead<nrows){temp<-c(temp,i+1)}

                if(polaritydown){
                        if(col<ncols){
                                temp<-c(temp,i+nrows)           
                                if(bead>1){temp<-c(temp,i+nrows-1)}
                        }
                        if(col>1){
                                temp<-c(temp,i-nrows)
                                if(bead>1){temp<-c(temp,i-nrows-1)}
                        }
                }
                else{
                        if(col<ncols){
                                temp<-c(temp,i+nrows)   
                                if(bead<nrows){temp<-c(temp,i+nrows+1)}
                        }
                        if(col>1){
                                temp<-c(temp,i-nrows)           
                                if(bead<nrows){temp<-c(temp,i-nrows+1)}
                        }
                }
                NN[i,1:length(temp)]<-temp
                }#bead
            polaritydown<-(!polaritydown)
            }#col
        polaritydown<-storepolaritydown
        }#segment
    return(NN)
}

####################################################
## Identify beads neighbouring undecoded clusters
####################################################


givenrow<-function(x, UndecNN){
    NDclass<-NULL
    tobeadded<-x
    while(length(tobeadded)>0){
        newx<-tobeadded[1]
        NDclass<-c(NDclass,newx)
        tobeadded<-tobeadded[-1]
        temp<-UndecNN[newx,2:7]
        temp<-temp[!is.na(temp)]
        temp<-temp[!(temp %in% NDclass)]
        temp<-temp[!(temp %in% tobeadded)]
        tobeadded<-c(tobeadded,temp)
    }
    return(NDclass)
}


takeclusterexpand <- function(probelist, newNN){
        probelist<-probelist[!is.na(probelist)]
        probelist<-as.vector(newNN[probelist,])
        probelist<-probelist[!is.na(probelist)]
        probelist<-unique(probelist)
        probelist
}    


nearNonDecodedClusters <- function(combed, NN) {
    
    revind<-cbind(1:nrow(combed),combed[,5])[order(combed[,5]),]      
    newNN<-cbind(1:nrow(combed),NN)

    for(k in 1:7){
        newNN[!is.na(newNN[,k]),k]<-revind[newNN[!is.na(newNN[,k]),k],1]
    }

    newNN<-newNN[order(newNN[,1]),]

    limUD<-sum(combed[,1]==0)
    UndecNN<-newNN[1:limUD,]

    UndecNN[UndecNN>limUD]<-NA

    targs<-which(apply(!is.na(UndecNN[,2:7]),1,sum)==6)

    toassign<-rep(F,limUD)
    toassign[targs]<-T
    nclass<-0
    maxsize<-0

    while(sum(toassign)>0){
        temp<-givenrow(min(which(toassign)), UndecNN)
        maxsize<-max(maxsize,length(temp))
        toassign[temp]<-F
        nclass<-nclass+1
    }

    NDclasses<-matrix(NA,nrow=maxsize,ncol=nclass)

    toassign<-rep(F,limUD)
    toassign[targs]<-T
    nclass<-0
    maxsize<-0

    while(sum(toassign)>0){
        temp<-givenrow(min(which(toassign)), UndecNN)
        toassign[temp]<-F
        nclass<-nclass+1
        NDclasses[1:length(temp),nclass]<-temp
    }

    if((is.null(ncol(NDclasses))) || (ncol(NDclasses) == 0) ) {
        message("No clusters")
        return(NA);
    }

    minclust<-50
    NDclasses <- NDclasses[,apply(!is.na(NDclasses),2,sum)>=minclust]
    if(length(NDclasses > 0) && (!is.matrix(NDclasses)))
        NDclasses <- matrix(NDclasses, ncol = 1)

    #### Now we have our clusters
    if((is.null(ncol(NDclasses))) || (ncol(NDclasses) == 0) ) {
        message("No clusters")
        return(NA);
    }

    idx <- NULL
    for(i in 1:ncol(NDclasses)) {
        
        temp1 <- NDclasses[,i]
        temp1<-temp1[!is.na(temp1)]
        temp2 <- temp1
        for(j in 1:5) {
            temp2 <- takeclusterexpand(temp2, newNN);
        }
        idx <- c(idx, temp2[!(temp2 %in% temp1)])
    }
    return(idx)
}

###############################################
## Identify the neighbours of large bright beads
###############################################

nearest <- function(largeSpots, coords) {
    return( which( ( abs(coords[,1] - largeSpots[1]) < 3) & ( abs(coords[,2] - largeSpots[2]) < 3 ) ));
}

excludeBrightBeadNeighbours <- function(combined, tiffImage, neighbours = NULL, thresh = 20) {

        tiff <- readImage(tiffImage);
        
        beadMask <- thresh(tiff, 10, 10, 0.05)
        seg <- bwlabel(beadMask)
        hf <- hullFeatures(seg)

        coords <- cbind(combined[,3:4]);      
        largeSpots <- matrix(hf[which(hf[,3] > thresh),], ncol = 16)
        
        tmp <- unlist(apply(largeSpots, 1, nearest, coords))
        
        if(is.null(neighbours))
            neighbours <- neighboursMatrixForAll();
        neighbours[which(is.na(neighbours))] <- 0;
        
        excludeIdx <- as.vector(unique(neighbours[tmp,]))
        return(excludeIdx);
}


##################################################
## identifying neighbours of the same bead types
##################################################

identifyMatchingNeighbours <- function(x, probeIDList) {
        probeID = x[1]
        indices = x[2:7]
        if(probeID %in% probeIDList[indices]) {
            return(TRUE)
        }
        else {
            return(FALSE)
        }
}

## highlight the pixels used to calculate the foreground with weighting shown
foregroundWeights <- function(tiff, xPos, yPos, lwd, border = "black") {

  x <- xPos - floor(xPos)
  y <- yPos - floor(yPos)
  
  #start in the bottom left corner of the foreground region
  xPos <- floor(xPos) - 1.5
  yPos <- floor(yPos) - 1.5

  #weights matrix
  w <- matrix(0.5, ncol = 4, nrow = 4)
  w[2:3,2:3] <- 1
  w[1,1] <- (1 - x) * (1 - y)
  w[1,2:3] <- (1 - y)
  w[1,4] <- x * (1 - y)
  w[2:3,1] <- (1 - x)
  w[2:3,4] <- x
  w[4,1] <- (1 - x) * y
  w[4,2:3] <- y
  w[4,4] <- x * y

  #divide by 2 because the weight is the radius of the circle, rather than the diameter
  w <- w / 2

  #sequence to draw the cirles
  s <- seq(0, 2*pi, 0.01)
  
  for(i in 1:4) {
    for(j in 1:4) {
      polygon((w[i,j] * cos(s)) + xPos + j - 0.5, (w[i,j] * sin(s)) + yPos + i - 0.5, lwd = lwd, border = border)
    }
  }
  rect(xPos, yPos, xPos+4, yPos+4)
}

###################################################
## Calculating the mean within bead-type variance
## when shifting the grid of bead centres
##################################################

## functions to convert between position in the linear locs file
## and pair of coordinates in the grid

locsIndicesToGrid <- function(x, nrow, ncol) {
    idx <- x - 1;
    col <- abs( ( ( idx %% (ncol * nrow) ) %/% nrow)) + 1;
    row <- 2 * (idx %% nrow) + 1;    
    if(col %% 2 == 0) 
            row <- row + 1;    
    return(c(col, row));
}


gridToLocsIndices <- function(x, nrow, ncol) {
    col <- x[1]; row <- x[2];
    if(col %% 2 == 1)
        row <- row + 1;
    row <- row %/% 2;
    idx <- ((col - 1) * nrow) + row;
    return(idx)
}

gridShift <- function(seg, xShift, yShift, nRows, nCols) {

    if((xShift %% 2) == (yShift %% 2)) {
        originalGrid <- t(sapply(seg[,5], locsIndicesToGrid, nrow = nRows, ncol = nCols));
        newGrid <- cbind(originalGrid[,1] + xShift, originalGrid[,2] + yShift)
        newIndex <- apply(newGrid, 1, gridToLocsIndices, nRows, nCols)
                
        ## fix those outside the grid to zero
        newIndex[which( (newGrid[,1] < 1) | (newGrid[,2] < 1) )] <- 0
        newIndex[which( (newGrid[,1] > nCols) | (newGrid[,2] > (nRows * 2)) )] <- 0
        
        tmpSeg <- seg
        tmpSeg[which(newIndex == 0),1] <- 0
        tmpSeg[which(newIndex != 0),1] <- seg[newIndex,1]
        tmpSeg <- tmpSeg[-which(tmpSeg[,1] == 0),]
        tmpSeg <- tmpSeg[-which(tmpSeg[,2] == 0),]
        return(tmpSeg)  
    }
    else { return(NULL) }
}

 ## move the grid of bead intensities and calculate the mean 
 ## within bead-type variance
testGridShift <- function(seg, xShift, yShift, nRows, nCols) {  

    tmpSeg <- gridShift(seg, xShift, yShift, nRows, nCols)
    if(!is.null(tmpSeg))    {
        tmpSeg[which(tmpSeg[,2] <= 0),2] <- 0.001
        s <- split(log2(tmpSeg[,2]), tmpSeg[,1])
        v <- lapply(s, var, na.rm = TRUE)
        return(mean(unlist(v), na.rm = T));
    }
    else { return(NA) }
}

###########################################################
## Calculating deviation from the grid
###########################################################


fitModelToGrid <- function(locs, nrow = NULL, ncol = NULL) {

## Similar functionality to that used in beadarrayBinary, but predicting the pixel
## location based on grid position, rather than the other way around
       
  if(is.null(nrow) || is.null(ncol)) {
    segsize <- which((locs[-1,1]-locs[-length(locs[,1]),1])>100)[1]
    seg <- locs[1:segsize,]
    tempy <- which(seg[-length(seg[,2]),2]>seg[-1,2])
    nrow <- as.numeric(names(sort(table(tempy[-1]-tempy[-length(tempy)]),decreasing=T))[1]) 
    ncol <- segsize/nrow
  }

  nSegs <- nrow(locs) / (nrow * ncol);

  res <- list()

  ## store the max ycoord of the previous segment
  prevMaxY <- 0
  
  ## process each segment at a time
  for(i in 1:nSegs ) {
    
    seg <- locs[( (nrow * ncol * (i-1) ) + 1):(nrow * ncol * i),  ]
    nrow2 <- 2 * nrow;
    grid <- cbind(rep(0:(ncol-1), each = nrow), rep(seq(0,(nrow2-1),2) , ncol))
    idx <- which(as.logical(grid[,1] %% 2))
    grid[idx,2] <- grid[idx,2]+1;

    ## adjust for overlapping segments
    ## store the adjust coords and grid indices
    if( floor(min(seg[,2])) < prevMaxY ) {
      message("Overlapping segment found! Adjusting...");
      shift <- prevMaxY - floor(min(seg[,2])) + 1
      seg[,2] <- seg[,2] + shift
      res[[4*i-1]] <- c(shift, floor(min(seg[,2])), ceiling(max(seg[,2])));
    }
    else {
      res[[4*i-1]] <- c(0, floor(min(seg[,2])), ceiling(max(seg[,2])));
    }
    prevMaxY <- ceiling(max(seg[,2]))
    res[[(4*i)-3]] <- seg
    res[[(4*i)-2]] <- grid %% 15

    ## fit the lm to the adjusted coords and store the coefficients
    lmX <- lm(seg[,1] ~ 1 + grid[,1] + grid[,2])
    lmY <- lm(seg[,2] ~ 1 + grid[,1] + grid[,2])
    res[[4*i]] <- c(lmX$coefficients, lmY$coefficients)
    
  }

  resList <- list();
  resList[[1]] <- res[[1]];
  resList[[2]] <- res[[2]];
  resList[[3]] <- res[[3]];
  resList[[4]] <- res[[4]];
  if(nSegs > 1) {
      for(i in seq(5, length(res), 4)) {
          resList[[1]] <- rbind(resList[[1]], res[[i]]);
          resList[[2]] <- rbind(resList[[2]], res[[i+1]]);
          resList[[3]] <- c(resList[[3]], res[[i+2]]);
          resList[[4]] <- c(resList[[4]], res[[i+3]]);
      }
  }
  resList[[5]] <- c(nSegs, nrow, ncol, ncol * nrow);
  
  return(resList);
}


### Euclidean distance function
dist <- function(o) {
    return(sqrt((o[1] - o[3])^2 + (o[2] - o[4])^2));
}


## Calculate how far from a predicted grid position a bead is
deviationFromGrid <- function(txt, locs, combined = NULL, includeNonDecoded = FALSE) {

  if(is.null(combined))
     combined <- BeadDataPackR:::combineFiles(txt, locs);

  modelParams <- fitModelToGrid(locs);
  predX <- predY <- distances <- vector(length = nrow(combined))
  
  ##loop over each segment
  #cat("Segment: ");
  for(i in 1:modelParams[[5]][1]) {
    #cat(" ", i);
    idx <- which( (combined[,5] >= (((i-1) * modelParams[[5]][4]) + 1)) & (combined[,5] <= (i * modelParams[[5]][4]) ))
    seg <- cbind(idx, combined[idx,3:5]);
    seg <- seg[order(seg[,4]),]
    coeff <- modelParams[[4]][(6*i-5):(6*i)];

    grid <- cbind(rep(0:(modelParams[[5]][3]-1), each = modelParams[[5]][2]), rep(seq(0,((modelParams[[5]][2]*2)-1),2) , modelParams[[5]][3]))
    idx <- which(as.logical(grid[,1] %% 2))
    grid[idx,2] <- grid[idx,2]+1;

    predX[seg[,1]] <- (coeff[1] + grid[,1] * coeff[2] + grid[,2] * coeff[3])
    predY[seg[,1]] <- (coeff[4] + grid[,1] * coeff[5] + grid[,2] * coeff[6])

    tmp <- cbind(predX[seg[,1]], predY[seg[,1]], seg[,2:3])
    distances[seg[,1]] <- apply(tmp, 1, dist);
  }
  #cat("\n");
  ## remove the non decoded beads if required
  if(!includeNonDecoded)
    distances <- distances[-which(combined[,1] == 0)]
  
  return(list(predX, predY, distances));
}


####################################################
## Indentify beads affected by bright beads, non-decoded clusters,
## or large deviation from grid
###################################################

identifyAffectedBeads <- function(arrayID, neighboursMatrix = NULL) {
    
    if(is.null(neighboursMatrix))
        neighboursMatrix <- neighboursMatrixForAll();
    
    message(arrayID);
    
    t1 <- matrix(unlist(scan(file = paste(arrayID, ".txt", sep = ""), what = list(0, 0, double(), double()), skip = 1, sep = "\t", quiet = TRUE)), ncol = 4);
    locs <- readLocs(paste(arrayID, "_Grn.locs", sep = ""))
    
    message("Combining Files")
    combined <- BeadDataPackR:::combineFiles(t1, locs)
    combinedOrd <- cbind(combined, 1:nrow(combined))[order(combined[,5]),]
    
    message("Identifying bright bead neighbours");
    nearBrightBeadsIdx <- excludeBrightBeadNeighbours(combined, tiffImage = paste(arrayID, "_Grn.tif", sep = ""), neighbours = neighboursMatrix)
    weights <- rep(1, nrow(locs))
    weights[combinedOrd[nearBrightBeadsIdx,6]] <- 0;
    
    message("Identify beads neighbouring non-decoded clusters");
    nonDecodedIdx <- nearNonDecodedClusters(combined, neighboursMatrix);
    weights[nonDecodedIdx] <- 0;
    
    message("Calculating deviation from grid");
    d <- deviationFromGrid(t1, locs, combined = combined)
    largeDeviationIdx <- which(d[[3]] > 1.5)

    weights[largeDeviationIdx] <- 0;
    weights <- weights[-which(combined[,1] == 0)];
    return(weights);
    
}



##################################################
## Functions to create model beads and pixelate them
###################################################

createBead <- function(xOffset = 0.5, yOffset = 0.5, gridSize = 13) {
    
    #convert offsets from fraction of a pixel into the required coordinates
    if(gridSize %% 2) {
        xOffset = (xOffset * (4 / gridSize)) - (2 / gridSize)
        yOffset = (yOffset * (4 / gridSize)) - (2 / gridSize)
    }
    else {
        xOffset = (xOffset * (4 / gridSize))
        yOffset = (yOffset * (4 / gridSize))
    }
    
    coords <- matrix(nrow = 500 * 501, ncol = 3)
    coords[,1] <- rep(seq(-2,2,4/500), 500)
    coords[,2] <- rep(seq(-2,2,4/500), each = 500)
    coords[,3] <- sqrt(coords[,1]^2 + coords[,2]^2)
    
    coords[,1] <- ((coords[,1] - min(coords[,1]) + xOffset) %% (max(coords[,1]) - min(coords[,1])+0.001)) + min(coords[,1])
    coords[,2] <- ((coords[,2] - min(coords[,2]) + yOffset) %% (max(coords[,2]) - min(coords[,2])+0.001)) + min(coords[,2])
    return(coords)
}

pixelateBead <- function(coords, gridSize = 13, maxInten = 65536) {
    
  xDivisions <- seq(floor(min(coords[,1])), ceiling(max(coords[,1])), (ceiling(max(coords[,1])) - floor(min(coords[,1]))) / gridSize)
  yDivisions <- seq(floor(min(coords[,2])), ceiling(max(coords[,2])), (ceiling(max(coords[,2])) - floor(min(coords[,2]))) / gridSize)
    
  Xidx <- floor(((coords[,1] - -2) / (2 - -2)) * gridSize)+1
  Yidx <- floor(((coords[,2] - -2) / (2 - -2)) * gridSize)+1
  XYidx = (Xidx) + (gridSize * (Yidx-1))
    
  pixels <- matrix(ncol = gridSize, nrow = gridSize);
  
  test <- split(coords[,3], XYidx)
    
  for(i in 1:nrow(pixels)) {
    for(j in 1:ncol(pixels)) {
      pixels[i, j] <- (maxInten) * (mean(1 - test[[j + (gridSize * (i - 1))]]^2))
    }
  }
  pixels[pixels < 0] = 0
  return(pixels)
}

round2 <- function(x, digits) round(x*(1+1e-15), digits) 

matrixForeground <- function(pixels, xOffset, yOffset) {
    
    if(xOffset < 0.5) 
        x <- abs(xOffset + 0.5)
    else
        x <- abs(xOffset - 0.5)
        
    if(yOffset < 0.5) 
        y <- abs(yOffset + 0.5)
    else
        y <- abs(yOffset - 0.5)
        
    col <- floor(ncol(pixels)/2)
    row <- floor(nrow(pixels)/2)

    weights <- matrix(c( (1-x)*(1-y), 1-y, 1-y, x*(1-y),
                        1-x, 1, 1, x,
                        1-x, 1, 1, x,
                        (1-x)*y, y, y, x*y), byrow = TRUE, ncol = 4)
                         
    return(sum(weights * pixels[row:(row+3), col:(col+3)]) / 9)
}

imagePlot <- function(data, high = "white", low = "black", ncolours = 100, scale = TRUE) {  
  
    high = col2rgb(high)/255
    low = col2rgb(low)/255
    colours = rgb(seq(low[1], high[1], len = ncolours), seq(low[2], high[2], len = ncolours), seq(low[3], high[3], len = ncolours))

    coloursIndex = floor((data - min(data)) * ((ncolours - 1) / (max(data) - min(data)))) + 1
    col = colours[t(coloursIndex)]
    
    if(scale) {
        layout(as.matrix(c(1:2)), heights = c(5,1))
        
        par(mar = c(1,1,1,1))
        plot(0,0, col = "white", xlim = c(0, ncol(data)), ylim = c(0, nrow(data)), xaxs = "i", yaxs = "i", xlab = "", ylab = "", tcl = 0, xaxt = "n", yaxt = "n", fg = "white")
        rect(xleft = rep(0:(ncol(data)-1), nrow(data)), ybottom = rep(0:(nrow(data)-1), each = ncol(data)), xright = rep(1:(ncol(data)), nrow(data)), ytop = rep(1:(nrow(data)), each = ncol(data)), col = as.vector(col), border = NA)
        
        par(mar = c(2,1,0,1))
        plot(0,0, col = "white", xlim = c(0, 100), ylim = c(0,1), xaxs = "i", yaxs = "i", tcl = 0, xaxt = "n", yaxt = "n", fg = "white")
        rect(xleft = 0:99, ybottom = rep(0, 100), xright = 1:100, ytop = rep(1, 100), col = colours, border = NA)
        mtext(round(min(data), 4), side = 1, adj = 0)
        mtext(round(mean(c(max(data), min(data))), 4), side = 1, adj = 0.5)
        mtext(round(max(data), 4), side = 1, adj = 1)
    }
    else {
        par(mar = c(1,1,1,1))
        plot(0,0, col = "white", xlim = c(0, ncol(data)), ylim = c(0, nrow(data)), xaxs = "i", yaxs = "i", xlab = "", ylab = "", tcl = 0, xaxt = "n", yaxt = "n", fg = "white")
        rect(xleft = rep(0:(ncol(data)-1), nrow(data)), ybottom = rep(0:(nrow(data)-1), each = ncol(data)), xright = rep(1:(ncol(data)), nrow(data)), ytop = rep(1:(nrow(data)), each = ncol(data)), col = as.vector(col), border = NA)
    }
}