library(iL04)

read.link <- function (file) 
{
    if (any(names(formals(scan)) == "comment.char")) {
        a <- scan(file = file, what = "", sep = "\n", strip.white = c(TRUE), 
            blank.lines.skip = TRUE, quiet = TRUE, comment.char = "#")
    } else {
        a <- scan(file = file, what = "", sep = "\n", strip.white = c(TRUE), 
            blank.lines.skip = TRUE, quiet = TRUE)
        a <- a[substr(a, 1, 1) != "#"]
    }
    size <- as.numeric(a[1])
    if (is.na(size)) 
        stop("Missing table size")
    if (length(a) < size + 1)
        stop("Illegal table size")
    dif <- matrix(FALSE, size, size)
    for (line in a[(size + 2):length(a)]) {
        i <- as.numeric(sub('\\s*([0-9]+).*', '\\1', line))
        j <- as.numeric(sub('\\s*[0-9]+\\s+([0-9]+).*', '\\1', line))
        dif[i, j] <- dif[j, i] <- TRUE
    }
    dif <- as.dist(t(dif))
    attr(dif, "Labels") <- a[(1 + 1):(1 + size)]
    dif
}

write.link <- function (lnk, file) 
{
    fp <- file(file, 'w')
    m <- as.matrix(lnk)
    n <- nrow(m)
    cat(n, rownames(m), sep = "\n", file = fp)
    for (i in 1:(n - 1)) {
        for (j in (i + 1):n) {
            if (m[i, j]) {
                cat(sprintf("%i %i\n", i, j), file = fp)
            }
        }
    }
    close(fp)
}


plot.link <- function(lnk, coo, map, asp=1, ...) {
    if (! all(labels(lnk) == rownames(coo))) stop ('Item mismatch')

    plot(map, asp=asp, type='l', ...)
  
    lnk2 <- as.matrix(lnk)
    n <- length(lnk2[,1])

    nlines <- length(lnk[lnk > 0])
    line <- matrix(NA, nrow = nlines * 3 - 1, ncol = 2)
    idx <- 0
    for (i in 2:n) {
        for (j in 1:(i-1)) {
            if (lnk2[i,j] > 0) {
                line[3 * idx + 1,1] <- coo[i,1]
                line[3 * idx + 2,1] <- coo[j,1]
                
                line[3 * idx + 1,2] <- coo[i,2]
                line[3 * idx + 2,2] <- coo[j,2]
                idx <- idx + 1
            }
        }
    }
    lines(line)
}

link.reduce <- function (lnk, coo, map, asp=1) {
    if (! all(labels(lnk) == rownames(coo))) stop ('Item mismatch')

  
    lnk2 <- as.matrix(lnk)
    n <- length(lnk2[,1])

    nlines <- length(lnk[lnk > 0])
    line <- matrix(NA, nrow = nlines * 3 - 1, ncol = 2)
    center <- matrix(NA, nrow = nlines, ncol = 4, dimnames=list(1:nlines, c('x', 'y', 'i', 'j')))
    idx <- 0
    for (i in 2:n) {
        for (j in 1:(i - 1)) {
            if (lnk2[i, j] > 0) {
                line[3 * idx + 1, 1] <- coo[i, 1]
                line[3 * idx + 2, 1] <- coo[j, 1]

                line[3 * idx + 1, 2] <- coo[i, 2]
                line[3 * idx + 2, 2] <- coo[j, 2]

                center[idx + 1, 1] <- (coo[i, 1] + coo[j, 1]) / 2
                center[idx + 1, 2] <- (coo[i, 2] + coo[j, 2]) / 2
                center[idx + 1, 3] <- i
                center[idx + 1, 4] <- j
                idx <- idx + 1
            }
        }
    }

    line2 <- line
    busy <- TRUE
    while (busy) {
        plot(map, type='l', asp=asp, col='#c0c0ff',
             axes=FALSE,
             sub='Left-click to mark, then right click to remove. Right-click twice to finish.',
             xlab='', ylab='')
        lines(line2)
        points(center, pch='o', col='#00d000')
        cc <- identify(center, labels = rep('x', nlines), offset=0)
        if (length(cc) == 0) {
            busy <- FALSE
        } else {
            line2[3 * cc - 1,] <- NA
            line2[3 * cc - 2,] <- NA
            center[cc,1:2] <- NA

            for (idx in cc) {
                i <- center[idx, 3]
                j <- center[idx, 4]
                lnk2[i, j] <- lnk2[j, i] <- 0
            }
        }
    }
    as.dist(lnk2)
}