## * Assign number of children to each edge (from "to" node)
nchild2edges <- function(tedges, from.node = NULL) {
    if (is.null(from.node))
        from.node <- setdiff(tedges$from, tedges$to)
    tedges[, nchildren := NA_integer_]

    children <- tedges[from %chin% from.node]
    while(nrow(children)) {
        nchild <- children[, .N, from]
        tedges[nchild, nchildren := i.N, on = c('to' = 'from')]
        children <- tedges[from %chin% children$to]
    }
    return(invisible(tedges))
}

get.root <- function(tedges) {
    setdiff(tedges$from, tedges$to)
}

## * Assign the distance to root to each edge
dist2root <- function(tedges, from.node = NULL) {
    stopifnot(all(c('dist', 'from', 'to') %in% names(tedges)))

    if (is.null(from.node))
        from.node <- setdiff(tedges$from, tedges$to)

    if (is.null(key(tedges)) || key(tedges) != 'from')
        setkey(tedges, from)

    tedges[, cumdist := 0]
    i <- 1L
    children <- tedges[from %in% from.node]
    while(nrow(children)) {
        tedges[from %in% children$from, `:=`(cumdist = cumdist + dist, nthnode = i)]
        prevchildren <- tedges[from %in% children$from]
        children <- tedges[from %in% children$to]
        tedges[prevchildren, cumdist := i.cumdist, on = c('from' = 'to')]
        i <- i + 1L
    }
    return(invisible(tedges))

}

children_unique_vals <- function(tedges, var) {

    tedges[, cladevar := get(var)]
    tedges[, cladestart := F]
    ## if (is.null(key(tedges)) || key(tedges) != 'from')
    ##     setkey(tedges, from)

    naval <- fcase(
        tedges[, is.character(get(var))], NA_character_,
        tedges[, is.integer(get(var))], NA_integer_,
        tedges[, is.numeric(get(var))], NA_real_,
        default = NA
    )

    getun <- function(x) {
        vs <- unique(setdiff(x, NA))
        if (length(vs) == 1L) {
            return(vs)
        } else return('multiple')
    }

    tedges[, uniquevals_children := get(var)]

    sel <- tedges[nthnode == max(nthnode)]
    uns <- sel[, .(uniquevals_children = getun(uniquevals_children)), from]
    tedges[uns, uniquevals_children := i.uniquevals_children, on = c('to' = 'from')]

    for (nn in (max(tedges$nthnode)-1):1L) {
        sel <- tedges[nthnode == nn]
        uns <- sel[, .(uniquevals_children = getun(uniquevals_children)), from]
        sel[uns, uniquevals_children_new := i.uniquevals_children, on = 'from']
        cladestarts <- sel[uniquevals_children_new == 'multiple' & uniquevals_children != 'multiple']
        tedges[cladestarts, cladestart := T, on = c('from' = 'to')]
        tedges[uns, uniquevals_children := i.uniquevals_children, on = c('to' = 'from')]
    }

}

## * Create edges data.table from phylo tree, and join tips data
get.edges <- function(tree) {
    tedges <- as.data.table(tree$edge)
    setnames(tedges, c('from', 'to'))
    tedges[, eid := .I]
    tedges[, dist := tree$edge.length]
    ttips <- get.tips(tree)
    tedges[, to.tip := V2 %in% ttips$id]
    tedges <- merge(tedges, ttips, by.x = 'V2', by.y = 'id', all.x = T, all.y = F, sort = F)
    setnames(tedges, c('V1', 'V2'), c('from', 'to'))
    setcolorder(tedges, c('from', 'to'))
    nchild2edges(tedges)
    dist2root(tedges)
    tedges
}

## * Extract clade of same trait, given a tip id, from edges data.table
common.trait.clade <- function(tedges, tip, var) {

    i <- 0L
    anc <- tedges[to == tip]
    val <- anc[, get(var)]
    if (is.na(val))
        stop('Need a tip with a non-NA value to start from')

    anc[, lvl := i]
    res <- anc

    sibs <- get.children(tedges, anc$from)
    cont <- sibs[, all(get(var) %in% c(NA, val))]

    while(cont) {
        sibs <- sibs[!res, on = 'to']
        sibs[, lvl := i]
        res <- rbind(res, sibs)
        i <- i + 1L
        anc <- tedges[to == anc$from]
        sibs <- get.children(tedges, anc$from)
        cont <- sibs[, all(get(var) %in% c(NA, val))]
    }

    return(res)
}

update.tree <- function(tedges) {
    tedges <- nchild2edges(tedges)
    tedges <- dist2root(tedges)
    tedges[, to.tip := fifelse(is.na(nchildren), T, F)]
    return(invisible(tedges))
}

## x=tree
## type = "fan"; use.edge.length = TRUE; node.pos = NULL;
## show.tip.label = FALSE; show.node.label = FALSE; edge.color = "grey50";
## edge.width = 1; edge.lty = 1; font = 3; cex = par("cex");
## adj = NULL; srt = 0; no.margin = TRUE; root.edge = FALSE;
## label.offset = 0; underscore = FALSE; x.lim = NULL; y.lim = NULL;
## direction = "rightwards"; lab4ut = NULL; tip.color = "red";
## plot = TRUE; rotate.tree = 0; open.angle = 0; node.depth = 1;
## align.tip.label = FALSE
## * Adaptation of ape::plot.phylo() to return the coordinates
plot2 <- function (x, type = "phylogram", use.edge.length = TRUE, node.pos = NULL,
    show.tip.label = TRUE, show.node.label = FALSE, edge.color = "black",
    edge.width = 1, edge.lty = 1, font = 3, cex = par("cex"),
    adj = NULL, srt = 0, no.margin = FALSE, root.edge = FALSE,
    label.offset = 0, underscore = FALSE, x.lim = NULL, y.lim = NULL,
    direction = "rightwards", lab4ut = NULL, tip.color = "black",
    plot = TRUE, rotate.tree = 0, open.angle = 0, node.depth = 1,
    align.tip.label = FALSE, ...) {

    Ntip <- length(x$tip.label)

    if (Ntip < 2) {
        warning("found less than 2 tips in the tree")
        return(NULL)
    }
    .nodeHeight <- function(edge, Nedge, yy) .C(node_height,
        as.integer(edge[, 1]), as.integer(edge[, 2]), as.integer(Nedge),
        as.double(yy))[[4]]
    .nodeDepth <- function(Ntip, Nnode, edge, Nedge, node.depth) .C(node_depth,
        as.integer(Ntip), as.integer(edge[, 1]), as.integer(edge[,
            2]), as.integer(Nedge), double(Ntip + Nnode), as.integer(node.depth))[[5]]
    .nodeDepthEdgelength <- function(Ntip, Nnode, edge, Nedge,
        edge.length) .C(node_depth_edgelength, as.integer(edge[,
        1]), as.integer(edge[, 2]), as.integer(Nedge), as.double(edge.length),
        double(Ntip + Nnode))[[5]]
    Nedge <- dim(x$edge)[1]
    Nnode <- x$Nnode
    if (any(x$edge < 1) || any(x$edge > Ntip + Nnode))
        stop("tree badly conformed; cannot plot. Check the edge matrix.")
    ROOT <- Ntip + 1
    type <- match.arg(type, c("phylogram", "cladogram", "fan",
        "unrooted", "radial"))
    direction <- match.arg(direction, c("rightwards", "leftwards",
        "upwards", "downwards"))
    if (is.null(x$edge.length)) {
        use.edge.length <- FALSE
    } else {
        if (use.edge.length && type != "radial") {
            tmp <- sum(is.na(x$edge.length))
            if (tmp) {
                warning(paste(tmp, "branch length(s) NA(s): branch lengths ignored in the plot"))
                use.edge.length <- FALSE
            }
        }
    }
    if (is.numeric(align.tip.label)) {
        align.tip.label.lty <- align.tip.label
        align.tip.label <- TRUE
    } else {
        if (align.tip.label)
            align.tip.label.lty <- 3
    }
    if (align.tip.label) {
        if (type %in% c("unrooted", "radial") || !use.edge.length ||
            is.ultrametric(x))
            align.tip.label <- FALSE
    }
    if (type %in% c("unrooted", "radial") || !use.edge.length ||
        is.null(x$root.edge) || !x$root.edge)
        root.edge <- FALSE
    phyloORclado <- type %in% c("phylogram", "cladogram")
    horizontal <- direction %in% c("rightwards", "leftwards")
    xe <- x$edge
    if (phyloORclado) {
        phyOrder <- attr(x, "order")
        if (is.null(phyOrder) || phyOrder != "cladewise") {
            x <- reorder(x)
            if (!identical(x$edge, xe)) {
                ereorder <- match(x$edge[, 2], xe[, 2])
                if (length(edge.color) > 1) {
                  edge.color <- rep(edge.color, length.out = Nedge)
                  edge.color <- edge.color[ereorder]
                }
                if (length(edge.width) > 1) {
                  edge.width <- rep(edge.width, length.out = Nedge)
                  edge.width <- edge.width[ereorder]
                }
                if (length(edge.lty) > 1) {
                  edge.lty <- rep(edge.lty, length.out = Nedge)
                  edge.lty <- edge.lty[ereorder]
                }
            }
        }
        yy <- numeric(Ntip + Nnode)
        TIPS <- x$edge[x$edge[, 2] <= Ntip, 2]
        yy[TIPS] <- 1:Ntip
    }
    z <- reorder(x, order = "postorder")
    if (phyloORclado) {
        if (is.null(node.pos))
            node.pos <- if (type == "cladogram" && !use.edge.length)
                2
            else 1
        if (node.pos == 1)
            yy <- .nodeHeight(z$edge, Nedge, yy)
        else {
            ans <- .C(node_height_clado, as.integer(Ntip), as.integer(z$edge[,
                1]), as.integer(z$edge[, 2]), as.integer(Nedge),
                double(Ntip + Nnode), as.double(yy))
            xx <- ans[[5]] - 1
            yy <- ans[[6]]
        }
        if (!use.edge.length) {
            if (node.pos != 2)
                xx <- .nodeDepth(Ntip, Nnode, z$edge, Nedge,
                  node.depth) - 1
            xx <- max(xx) - xx
        }
        else {
            xx <- .nodeDepthEdgelength(Ntip, Nnode, z$edge, Nedge,
                z$edge.length)
        }
    } else {
        twopi <- 2 * pi
        rotate.tree <- twopi * rotate.tree/360
        if (type != "unrooted") {
            TIPS <- x$edge[which(x$edge[, 2] <= Ntip), 2]
            xx <- seq(0, twopi * (1 - 1/Ntip) - twopi * open.angle/360,
                length.out = Ntip)
            theta <- double(Ntip)
            theta[TIPS] <- xx
            theta <- c(theta, numeric(Nnode))
        }
        switch(type, fan = {
            theta <- .nodeHeight(z$edge, Nedge, theta)
            if (use.edge.length) {
                r <- .nodeDepthEdgelength(Ntip, Nnode, z$edge,
                  Nedge, z$edge.length)
            } else {
                r <- .nodeDepth(Ntip, Nnode, z$edge, Nedge, node.depth)
                r <- 1/r
            }
            theta <- theta + rotate.tree
            if (root.edge) r <- r + x$root.edge
            xx <- r * cos(theta)
            yy <- r * sin(theta)
        }, unrooted = {
            nb.sp <- .nodeDepth(Ntip, Nnode, z$edge, Nedge, node.depth)
            XY <- if (use.edge.length) unrooted.xy(Ntip, Nnode,
                z$edge, z$edge.length, nb.sp, rotate.tree) else unrooted.xy(Ntip,
                Nnode, z$edge, rep(1, Nedge), nb.sp, rotate.tree)
            xx <- XY$M[, 1] - min(XY$M[, 1])
            yy <- XY$M[, 2] - min(XY$M[, 2])
        }, radial = {
            r <- .nodeDepth(Ntip, Nnode, z$edge, Nedge, node.depth)
            r[r == 1] <- 0
            r <- 1 - r/Ntip
            theta <- .nodeHeight(z$edge, Nedge, theta) + rotate.tree
            xx <- r * cos(theta)
            yy <- r * sin(theta)
        })
    }
    if (phyloORclado) {
        if (!horizontal) {
            tmp <- yy
            yy <- xx
            xx <- tmp - min(tmp) + 1
        }
        if (root.edge) {
            if (direction == "rightwards")
                xx <- xx + x$root.edge
            if (direction == "upwards")
                yy <- yy + x$root.edge
        }
    }
    if (no.margin)
        par(mai = rep(0, 4))
    if (show.tip.label)
        nchar.tip.label <- nchar(x$tip.label)
    max.yy <- max(yy)
    getLimit <- function(x, lab, sin, cex) {
        s <- strwidth(lab, "inches", cex = cex)
        if (any(s > sin))
            return(1.5 * max(x))
        Limit <- 0
        while (any(x > Limit)) {
            i <- which.max(x)
            alp <- x[i]/(sin - s[i])
            Limit <- x[i] + alp * s[i]
            x <- x + alp * s
        }
        Limit
    }
    if (is.null(x.lim)) {
        if (phyloORclado) {
            if (horizontal) {
                xx.tips <- xx[1:Ntip]
                if (show.tip.label) {
                  pin1 <- par("pin")[1]
                  tmp <- getLimit(xx.tips, x$tip.label, pin1,
                    cex)
                  tmp <- tmp + label.offset
                }
                else tmp <- max(xx.tips)
                x.lim <- c(0, tmp)
            }
            else x.lim <- c(1, Ntip)
        } else switch(type, fan = {
            if (show.tip.label) {
                offset <- max(nchar.tip.label * 0.018 * max.yy *
                  cex)
                x.lim <- range(xx) + c(-offset, offset)
            } else x.lim <- range(xx)
        }, unrooted = {
            if (show.tip.label) {
                offset <- max(nchar.tip.label * 0.018 * max.yy *
                  cex)
                x.lim <- c(0 - offset, max(xx) + offset)
            } else x.lim <- c(0, max(xx))
        }, radial = {
            if (show.tip.label) {
                offset <- max(nchar.tip.label * 0.03 * cex)
                x.lim <- c(-1 - offset, 1 + offset)
            } else x.lim <- c(-1, 1)
        })
    } else if (length(x.lim) == 1) {
        x.lim <- c(0, x.lim)
        if (phyloORclado && !horizontal)
            x.lim[1] <- 1
        if (type %in% c("fan", "unrooted") && show.tip.label)
            x.lim[1] <- -max(nchar.tip.label * 0.018 * max.yy *
                cex)
        if (type == "radial")
            x.lim[1] <- if (show.tip.label)
                -1 - max(nchar.tip.label * 0.03 * cex)
            else -1
    }
    if (phyloORclado && direction == "leftwards")
        xx <- x.lim[2] - xx
    if (is.null(y.lim)) {
        if (phyloORclado) {
            if (horizontal)
                y.lim <- c(1, Ntip)
            else {
                pin2 <- par("pin")[2]
                yy.tips <- yy[1:Ntip]
                if (show.tip.label) {
                  tmp <- getLimit(yy.tips, x$tip.label, pin2,
                    cex)
                  tmp <- tmp + label.offset
                }
                else tmp <- max(yy.tips)
                y.lim <- c(0, tmp)
            }
        } else switch(type, fan = {
            if (show.tip.label) {
                offset <- max(nchar.tip.label * 0.018 * max.yy *
                  cex)
                y.lim <- c(min(yy) - offset, max.yy + offset)
            } else y.lim <- c(min(yy), max.yy)
        }, unrooted = {
            if (show.tip.label) {
                offset <- max(nchar.tip.label * 0.018 * max.yy *
                  cex)
                y.lim <- c(0 - offset, max.yy + offset)
            } else y.lim <- c(0, max.yy)
        }, radial = {
            if (show.tip.label) {
                offset <- max(nchar.tip.label * 0.03 * cex)
                y.lim <- c(-1 - offset, 1 + offset)
            } else y.lim <- c(-1, 1)
        })
    } else if (length(y.lim) == 1) {
        y.lim <- c(0, y.lim)
        if (phyloORclado && horizontal)
            y.lim[1] <- 1
        if (type %in% c("fan", "unrooted") && show.tip.label)
            y.lim[1] <- -max(nchar.tip.label * 0.018 * max.yy *
                             cex)
        if (type == "radial")
            y.lim[1] <- if (show.tip.label)
                            -1 - max(nchar.tip.label * 0.018 * max.yy * cex)
                        else -1
    }
    if (phyloORclado && direction == "downwards")
        yy <- y.lim[2] - yy
    if (phyloORclado && root.edge) {
        if (direction == "leftwards")
            x.lim[2] <- x.lim[2] + x$root.edge
        if (direction == "downwards")
            y.lim[2] <- y.lim[2] + x$root.edge
    }
    asp <- fifelse(type %in% c("fan", "radial", "unrooted"), 1, NA_integer_)
    plot.default(0, type = "n", xlim = x.lim, ylim = y.lim, xlab = "",
        ylab = "", axes = FALSE, asp = asp, ...)
    if (plot) {
        if (is.null(adj))
            adj <- fifelse(phyloORclado && direction == "leftwards", 1, 0)
        if (phyloORclado && show.tip.label) {
            MAXSTRING <- max(strwidth(x$tip.label, cex = cex))
            loy <- 0
            if (direction == "rightwards") {
                lox <- label.offset + MAXSTRING * 1.05 * adj
            }
            if (direction == "leftwards") {
                lox <- -label.offset - MAXSTRING * 1.05 * (1 - adj)
            }
            if (!horizontal) {
                psr <- par("usr")
                MAXSTRING <- MAXSTRING * 1.09 * (psr[4] - psr[3])/(psr[2] - psr[1])
                loy <- label.offset + MAXSTRING * 1.05 * adj
                lox <- 0
                srt <- 90 + srt
                if (direction == "downwards") {
                    loy <- -loy
                    srt <- 180 + srt
                }
            }
        }
        if (type == "phylogram") {
            phylogram.plot(x$edge, Ntip, Nnode, xx, yy, horizontal,
                           edge.color, edge.width, edge.lty)
        } else {
            if (type == "fan") {
                ereorder <- match(z$edge[, 2], x$edge[, 2])
                if (length(edge.color) > 1) {
                    edge.color <- rep(edge.color, length.out = Nedge)
                    edge.color <- edge.color[ereorder]
                }
                if (length(edge.width) > 1) {
                    edge.width <- rep(edge.width, length.out = Nedge)
                    edge.width <- edge.width[ereorder]
                }
                if (length(edge.lty) > 1) {
                    edge.lty <- rep(edge.lty, length.out = Nedge)
                    edge.lty <- edge.lty[ereorder]
                }
                circular.plot(z$edge, Ntip, Nnode, xx, yy, theta,
                              r, edge.color, edge.width, edge.lty)
            } else {
                cladogram.plot(x$edge, xx, yy, edge.color, edge.width, edge.lty)
            }
        }
        if (root.edge) {
            rootcol <- fifelse(length(edge.color) == 1, edge.color, 'black')
            rootw <- fifelse(length(edge.width) == 1, edge.width, 1)
            rootlty <- fifelse(length(edge.lty) == 1, edge.lty, 1)
            if (type == "fan") {
                tmp <- polar2rect(x$root.edge, theta[ROOT])
                segments(0, 0, tmp$x, tmp$y, col = rootcol, lwd = rootw,
                         lty = rootlty)
            } else {
                switch(direction,
                       rightwards = segments(0, yy[ROOT],
                                             x$root.edge, yy[ROOT], col = rootcol, lwd = rootw,
                                             lty = rootlty), leftwards = segments(xx[ROOT],
                                                                                yy[ROOT], xx[ROOT] + x$root.edge, yy[ROOT],
                                                                                col = rootcol, lwd = rootw, lty = rootlty),
                       upwards = segments(xx[ROOT], 0, xx[ROOT], x$root.edge,
                                          col = rootcol, lwd = rootw, lty = rootlty),
                       downwards = segments(xx[ROOT], yy[ROOT], xx[ROOT],
                                            yy[ROOT] + x$root.edge, col = rootcol, lwd = rootw,
                                            lty = rootlty))
            }
        }
        if (show.tip.label) {
            if (is.expression(x$tip.label))
                underscore <- TRUE
            if (!underscore)
                x$tip.label <- gsub("_", " ", x$tip.label)
            if (phyloORclado) {
                if (align.tip.label) {
                    xx.tmp <- switch(direction, rightwards = max(xx[1:Ntip]),
                                     leftwards = min(xx[1:Ntip]), upwards = xx[1:Ntip],
                                     downwards = xx[1:Ntip])
                    yy.tmp <- switch(direction, rightwards = yy[1:Ntip],
                                     leftwards = yy[1:Ntip], upwards = max(yy[1:Ntip]),
                                     downwards = min(yy[1:Ntip]))
                    segments(xx[1:Ntip], yy[1:Ntip], xx.tmp, yy.tmp,
                             lty = align.tip.label.lty)
                }
                else {
                    xx.tmp <- xx[1:Ntip]
                    yy.tmp <- yy[1:Ntip]
                }
                text(xx.tmp + lox, yy.tmp + loy, x$tip.label,
                     adj = adj, font = font, srt = srt, cex = cex,
                     col = tip.color)
            } else {
                angle <- if (type == "unrooted")
                             XY$axe
                         else atan2(yy[1:Ntip], xx[1:Ntip])
                lab4ut <- if (is.null(lab4ut)) {
                              if (type == "unrooted")
                                  "horizontal"
                              else "axial"
                          }
                          else match.arg(lab4ut, c("horizontal", "axial"))
                xx.tips <- xx[1:Ntip]
                yy.tips <- yy[1:Ntip]
                if (label.offset) {
                    xx.tips <- xx.tips + label.offset * cos(angle)
                    yy.tips <- yy.tips + label.offset * sin(angle)
                }
                if (lab4ut == "horizontal") {
                    y.adj <- x.adj <- numeric(Ntip)
                    sel <- abs(angle) > 0.75 * pi
                    x.adj[sel] <- -strwidth(x$tip.label)[sel] *
                        1.05
                    sel <- abs(angle) > pi/4 & abs(angle) < 0.75 *
                        pi
                    x.adj[sel] <- -strwidth(x$tip.label)[sel] *
                        (2 * abs(angle)[sel]/pi - 0.5)
                    sel <- angle > pi/4 & angle < 0.75 * pi
                    y.adj[sel] <- strheight(x$tip.label)[sel]/2
                    sel <- angle < -pi/4 & angle > -0.75 * pi
                    y.adj[sel] <- -strheight(x$tip.label)[sel] *
                        0.75
                    text(xx.tips + x.adj * cex, yy.tips + y.adj *
                                                cex, x$tip.label, adj = c(adj, 0), font = font,
                         srt = srt, cex = cex, col = tip.color)
                } else {
                    if (align.tip.label) {
                        POL <- rect2polar(xx.tips, yy.tips)
                        POL$r[] <- max(POL$r)
                        REC <- polar2rect(POL$r, POL$angle)
                        xx.tips <- REC$x
                        yy.tips <- REC$y
                        segments(xx[1:Ntip], yy[1:Ntip], xx.tips,
                                 yy.tips, lty = align.tip.label.lty)
                    }
                    if (type == "unrooted") {
                        adj <- abs(angle) > pi/2
                        angle <- angle * 180/pi
                        angle[adj] <- angle[adj] - 180
                        adj <- as.numeric(adj)
                    } else {
                        s <- xx.tips < 0
                        angle <- angle * 180/pi
                        angle[s] <- angle[s] + 180
                        adj <- as.numeric(s)
                    }
                    font <- rep(font, length.out = Ntip)
                    tip.color <- rep(tip.color, length.out = Ntip)
                    cex <- rep(cex, length.out = Ntip)
                    for (i in 1:Ntip) text(xx.tips[i], yy.tips[i],
                                           x$tip.label[i], font = font[i], cex = cex[i],
                                           srt = angle[i], adj = adj[i], col = tip.color[i])
                }
            }
        }
        if (show.node.label)
            text(xx[ROOT:length(xx)] + label.offset, yy[ROOT:length(yy)],
                 x$node.label, adj = adj, font = font, srt = srt,
                 cex = cex)
    }
    L <- list(type = type, use.edge.length = use.edge.length,
        node.pos = node.pos, node.depth = node.depth, show.tip.label = show.tip.label,
        show.node.label = show.node.label, font = font, cex = cex,
        adj = adj, srt = srt, no.margin = no.margin, label.offset = label.offset,
        x.lim = x.lim, y.lim = y.lim, direction = direction,
        tip.color = tip.color, Ntip = Ntip, Nnode = Nnode, root.time = x$root.time,
        align.tip.label = align.tip.label, coords = list(edge = xe, xx = xx, yy = yy))
    assign("last_plot.phylo", c(L, list(edge = xe, xx = xx, yy = yy)),
        envir = .PlotPhyloEnv)
    invisible(L)
}

get.children <- function(tedges, from.node = NULL) {
    if (is.null(from.node))
        from.node <- setdiff(tedges$from , tedges$to)
    res <- NULL
    i <- 0L
    if (is.null(key(tedges)) || key(tedges) != 'from')
        setkey(tedges, from)
    children <- tedges[from %in% from.node]
    while(nrow(children)) {
        children[, lvl := i]
        res <- rbind(res, children)
        children <- tedges[from %in% children$to]
        i <- i + 1L
    }
    res
}

get.parents <- function(tedges, from.node) {
    i <- 0L
    res <- vector("list", 1000)
    setkey(tedges, to)
    anc <- tedges[to %in% from.node]

    while(nrow(anc)) {
        anc[, lvl := i]
        i <- i + 1L
        res[[i]] <- anc
        anc <- tedges[to %in% anc$from]
    }
    rbindlist(res)
}

## * Convert subset of the edge data.table to phylo tree
edges2phylo <- function(tedges, idcol = 'virus_name', update.first = T) {

    e <- copy(tedges)
    if (update.first | !('to.tip' %in% names(tedges)))
        update.tree(e)

    rt <- get.root(e)

    tps <- e[to.tip == T, sort(unique(to))]
    ntips <- length(tps)
    nds <- c(rt, setdiff(sort(setdiff(unlist(e[, .(from, to)]), tps)), rt))
    nnodes <- length(nds)

    ## ** Re-name nodes and tips
    lkup <- data.table(id = c(tps, nds), is.tip = c(rep(T, length.out = ntips), rep(F, length.out = nnodes)))
    lkup[, newid := .I]
    setnames(e, c('from', 'to'), c('from.ori', 'to.ori'))

    e[lkup, from := i.newid, on = c('from.ori' = 'id')]
    e[lkup, to   := i.newid, on = c('to.ori'   = 'id')]
    setorder(e, -to.tip, to, from)

    m <- as.matrix(e[, .(from, to)])
    dimnames(m) <- NULL

    cols <- c('to', idcol)
    t <- list(edge        = m,
              edge.length = e$dist,
              Nnode       = nnodes,
              node.label  = NULL,
              tip.label   = e[to.tip == T, ..cols][order(to)][, get(idcol)]
              )
    class(t) <- 'phylo'
    attr(t, 'order') <- 'cladewise'

    list(phylo = t,
         edges = e)
}

## * Prepare data to be plotted - extract coordinates and make edges square if required
edges.plot.prep <- function(tedges, square.edges = T, id.col = 'vertex_id') {

    phy <- edges2phylo(tedges, idcol = id.col) # convert edges data.table back to phylo tree
    tt <- phy$phylo
    eds <- phy$edges

    ## checkValidPhylo(tt)

    ## ** Get coordinates without plotting
    p <- plot2(tt, type = 'phylogram', plot = F,
               show.tip.label = F, show.node.label = F,
               edge.color = 'black', tip.color = 'red', cex = 0,
               root.edge = F, use.edge.length = T,
               no.margin = T)

    ed <- data.table(p$coords$edge)
    xy <- data.table(x = p$coords$xx, y = p$coords$yy)
    xy[, id := .I]

    eds[xy, `:=`(from.x = i.x, from.y = i.y), on = c('from' = 'id')]
    eds[xy, `:=`(to.x = i.x, to.y = i.y), on = c('to' = 'id')]

    ## ** Make square segments
    if (square.edges) {
        e <- eds[from.x != to.x & from.y != to.y]
        ed <- e[, .(to.x = c(from.x, to.x), from.y = c(from.y, to.y), to.tip = c(F, first(to.tip)),
                    extra = c(T, F))
              , .(from, to, eid)]

        ed <- merge(ed, e[, c('eid', setdiff(names(e), names(ed))), with=F], by = 'eid')
        ed <- rbind(ed, eds[!(from.x != to.x & from.y != to.y)], fill = T)
    } else ed <- copy(eds)

    return(ed)
}

## * Assign common trait within clades

spread.clade.trait <- function(tedges, var, agg.var.name = 'children_common_trait') {

    if ('children_agg' %in% names(tedges))
        tedges[, children_agg := NULL]
    if (agg.var.name %in% names(tedges))
        tedges[, eval(agg.var.name) := NULL]
    tedges[, children_agg := get(var)]
    if ('curr_agg' %in% names(tedges))
        tedges[, curr_agg := NULL]

    ## aggval <- tedges[to.tip == T & !is.na(children_agg), mean(children_agg)]
    ## tedges[to.tip == T & is.na(children_agg), children_agg := aggval]

    mxnode <- tedges[, max(nthnode)]
    nod=mxnode-1
    for (nod in (mxnode-1):1L) {
        higher.lvl <- tedges[nthnode == nod+1L]
        higher.lvl[, curr_agg := fifelse(uniqueN(children_agg)==1, children_agg[1], 'multiple'), from]
        lower.lvl  <- tedges[nthnode == nod]
        ## lower.lvl[higher.lvl, children_agg := mean(i.children_agg, na.rm=T), on = c('to' = 'from')]
        lower.lvl[higher.lvl, children_agg := i.curr_agg, on = c('to' = 'from')]
        ## lower.lvl[higher.lvl, curr_agg := mean(i.children_agg, na.rm=T), on = c('to' = 'from')]
        tedges[lower.lvl, children_agg := i.children_agg, on = 'eid']
    }

    if (agg.var.name %in% names(tedges)) {
        tedges[, eval(agg.var.name) := NULL]
    }
    setnames(tedges, 'children_agg', agg.var.name)
    return(invisible(tedges))
}

spread.stat <- function(tedges, var, progress = T, agg.var.name = 'children_agg', stat.fun = mean) {

    tedges[, children_agg := get(var)]
    if ('curr_agg' %in% names(tedges))
        tedges[, curr_agg := NULL]

    aggval <- tedges[to.tip == T & !is.na(children_agg), mean(children_agg)]
    tedges[to.tip == T & is.na(children_agg), children_agg := aggval]

    mxnode <- tedges[, max(nthnode)]
    nod=mxnode-1
    for (nod in (mxnode-1):1L) {
        higher.lvl <- tedges[nthnode == nod+1L]
        higher.lvl[, curr_agg := stat.fun(children_agg, na.rm=T), from]
        lower.lvl  <- tedges[nthnode == nod]
        ## lower.lvl[higher.lvl, children_agg := mean(i.children_agg, na.rm=T), on = c('to' = 'from')]
        lower.lvl[higher.lvl, children_agg := i.curr_agg, on = c('to' = 'from')]
        ## lower.lvl[higher.lvl, curr_agg := mean(i.children_agg, na.rm=T), on = c('to' = 'from')]
        tedges[lower.lvl, children_agg := i.children_agg, on = 'eid']
    }

    setnames(tedges, 'children_agg', agg.var.name)

}

## points = NULL
## width = 55.5; height = 50; square.edges = T;
## edges.colour.by = 'children_trait'; points.colour.by = 'children_trait';
## palette.fun = NULL; z.var = NULL; z.trans.fun = I; max.z = 2e6;
## bgcol = '#EEEEEE'; tooltip = T;
## edge.vars = c('accession_id', 'vertex_id', 'children_trait');
## point.vars = c('accession_id', 'collection_date', 'continent',
##                'country', 'host', 'clade', 'lineage', 'children_trait');
## node.lab.glue = "ID: {accession_id}<br>Continent: {continent}<br>country: {country}<br>Date: {collection_date}";
## edge.lab.glue = "ID: {accession_id}<br>Vertex ID: {vertex_id}<br>{children_trait}"

tree2deck <- function(tedges, points = NULL, width = 55.5, height = 50, square.edges = T,
                      edges.colour.by = 'children_trait', points.colour.by = 'children_trait',
                      thickness.var = 'children_agg',
                      palette.fun = NULL, z.var = NULL, z.trans.fun = I, max.z = 2e6,
                      bgcol = '#EEEEEE', tooltip = T,
                      edge.vars = c('eid', 'continent_spread', 'country_spread'),
                      point.vars = c('eid', 'continent_spread', 'country_spread'),
                      node.lab.glue = '{eid}<br>{continent_spread}<br>{country_spread}',
                      edge.lab.glue = '{eid}<br>{continent_spread}<br>{country_spread}') {
    library(deckgl)

    in3D <- !is.null(z.var)
    if (in3D)
        tedges[, zval := get(z.var)]

    if (!('to.tip' %in% names(tedges)))
        tedges <- update.tree(tedges)

    e <- tedges

    if (is.null(points)) {
        t <- e[to.tip == T]
    } else t <- points

    if (!is.null(edges.colour.by) && !(edges.colour.by %in% names(e)))
        edges.colour.by <- NULL
    if (!is.null(points.colour.by) && !(points.colour.by %in% names(t)))
        points.colour.by <- NULL

    ## ** Colour
    if (!is.null(edges.colour.by)) {
        if (is.numeric(e[[edges.colour.by]])) {
            e[, colour := scales::cscale(get(edges.colour.by),
                                         scales::gradient_n_pal(colours = gplots::rich.colors(30)))]
        } else {
            if (e[!is.na(get(edges.colour.by)), all(grepl('^#', get(edges.colour.by)))]) {
                e[, colour := get(edges.colour.by)]
            } else {
                e[, colour := scales::dscale(factor(get(edges.colour.by)),
                                             pals::alphabet)]
            }
        }
    } else e[, colour := NA_character_]
    e[is.na(colour), colour := '#AAAAAA']

    if (!is.null(points.colour.by)) {
        if (points.colour.by %in% names(t)) {
            if (is.numeric(t[[points.colour.by]])) {
                t[, colour := scales::cscale(get(points.colour.by),
                                             scales::gradient_n_pal(colours = gplots::rich.colors(30)))]
            } else {
                if (t[!is.na(get(points.colour.by)), all(grepl('^#', get(points.colour.by)))]) {
                    t[, colour := get(points.colour.by)]
                } else {
                    t[, colour := scales::dscale(factor(get(points.colour.by)),
                                                 gplots::rich.colors)]
                }
            }
        } else t[, colour := points.colour.by] # if colour var not a field, assume it's a colour
    } else t[, colour := NA_character_]
    t[is.na(colour), colour := '#AAAAAA']

    maxx <- max(e$to.x)
    maxy <- max(e$to.y)

    t[, x := scales::rescale(to.x, c(0, width) , c(0, maxx))]
    t[, y := scales::rescale(to.y, c(0, height), c(0, maxy))]

    e[, start_x := scales::rescale(from.x, c(0, width), c(0, maxx))]
    e[, start_y := scales::rescale(from.y, c(0, height), c(0, maxy))]
    e[, end_x := scales::rescale(to.x, c(0, width), c(0, maxx))]
    e[, end_y := scales::rescale(to.y, c(0, height), c(0, maxy))]
    if (!is.null(thickness.var) && thickness.var %in% names(e)) {
        e[, linewidth := scales::rescale(sqrt(get(thickness.var)), c(1, 20))]
    } else e[, linewidth := 1]

    if (in3D) {
        zrange <- e[, range(zval, na.rm=T)]
        t[, z       := scales::rescale(z.trans.fun(zval)    , c(0, max.z), z.trans.fun(zrange))]
        e[, start_z := scales::rescale(z.trans.fun(curr_agg), c(0, max.z), z.trans.fun(zrange))]
        e[, end_z   := scales::rescale(z.trans.fun(zval)    , c(0, max.z), z.trans.fun(zrange))]
    } else {
        t[, z := NA]
        e[, c('start_z', 'end_z') := NA]
    }

    vars <- c('x', 'y', 'z', 'colour', point.vars)
    pp <- t[, ..vars]
    vars <- c('start_x', 'start_y', 'start_z', 'end_x', 'end_y', 'end_z', 'colour', 'linewidth', edge.vars)
    ll <- e[, ..vars]

    root <- setdiff(tedges$from, tedges$to)
    rootpt <- e[from == root][1, .(start_x, start_y, start_z, end_x, end_y, end_z, eid)]

    pp[, label := glue::glue(node.lab.glue, envir = .SD)]
    ll[, label := as.character(glue::glue(edge.lab.glue, envir = .SD))]

    leg <- tedges[!is.na(colour), .N, c(edges.colour.by, 'colour')][order(get(edges.colour.by))]
    setnames(leg, edges.colour.by, 'val')

    if (in3D) {

        if (tooltip) {

            proplines <- list(
                getSourcePosition = ~ start_x + start_y + start_z,
                getTargetPosition = ~ end_x + end_y + end_z,
                getTooltip = JS("object =>`${object.label}`"),
                getWidth = 1,
                pickable = T,
                opacity = 0.5,
                visible = T,
                getColor = get_color_to_rgb_array('colour')
            )

            proppoints <- list(
                getPosition = ~ x + y + z,
                getColor = get_color_to_rgb_array('colour'),
                getFillColor = get_color_to_rgb_array('colour'),
                getRadius = 1000,
                getTooltip = JS("object =>`${object.label}`"),
                stroked = T,
                pointSize = 2,
                radiusScale = 8,
                radiusMinPixels = 1.5,
                radiusMaxPixels = 5,
                opacity = 0.8
            )

            proproot <- list(
                getPosition = ~ start_x + start_y + start_z,
                getColor = '#000000',
                getFillColor = '#FFFFFF',
                getRadius = 1000,
                getTooltip = "Tree root<br>Epi-id: {{eid}}",
                stroked = T,
                radiusScale = 8,
                radiusMinPixels = 5,
                radiusMaxPixels = 15,
                opacity = 1
            )

            deck <- deckgl(width='100vw', height='100vh', latitude = 25, longitude = 25, zoom = 3,
                           pitch = fifelse(in3D, 60, 0), maxPitch = 89.9,
                           style = list(background = bgcol)) %>%
                add_line_layer(data = ll[, .(start_x, start_y, start_z, end_x, end_y, end_z, colour, label)],
                               properties = proplines) %>%
                add_scatterplot_layer(data = pp[, .(x, y, z, colour, label)], properties = proppoints) %>%
                add_scatterplot_layer(data = rootpt[, .(start_x, start_y, start_z, eid)], properties = proproot) %>%
                add_legend(
                    colors = leg$colour,
                    labels = leg$val,
                    title = '',
                    pos = 'top-left'
                )

        } else {

            proppoints <- list(
                getPosition = ~ x + y + z,
                getColor = get_color_to_rgb_array('colour'),
                getFillColor = get_color_to_rgb_array('colour'),
                getRadius = 1000,
                stroked = T,
                pointSize = 2,
                radiusScale = 8,
                radiusMinPixels = 1.5,
                radiusMaxPixels = 5,
                opacity = 0.8
            )

            proplines <- list(
                getSourcePosition = ~ start_x + start_y + start_z,
                getTargetPosition = ~ end_x + end_y + end_z,
                getWidth = 1,
                pickable = T,
                opacity = 0.5,
                visible = T,
                getColor = get_color_to_rgb_array('colour')
            )

            proproot <- list(
                getPosition = ~ start_x + start_y + start_z,
                getColor = '#000000',
                getFillColor = '#FFFFFF',
                getRadius = 1000,
                stroked = T,
                radiusScale = 8,
                radiusMinPixels = 5,
                radiusMaxPixels = 15,
                opacity = 1
            )

            deck <- deckgl(width='100vw', height='100vh', latitude = 25, longitude = 25, zoom = 3,
                           pitch = fifelse(in3D, 60, 0), maxPitch = 89.9,
                           style = list(background = bgcol)) %>%
                add_line_layer(data = ll[, .(start_x, start_y, start_z, end_x, end_y, end_z, colour)],
                               properties = proplines) %>%
                add_scatterplot_layer(data = pp[, .(x, y, z, colour)], properties = proppoints) %>%
                add_scatterplot_layer(data = rootpt[, .(start_x, start_y, start_z)], properties = proproot) %>%
                add_legend(
                    colors = leg$colour,
                    labels = leg$val,
                    title = '',
                    pos = 'top-left'
                )

        }

    } else {

        if (tooltip) {

            proplines <- list(
                getSourcePosition = ~ start_x + start_y,
                getTargetPosition = ~ end_x + end_y,
                getTooltip = JS("object =>`${object.label}`"),
                getWidth = ~ linewidth,
                widthScale = 1,
                pickable = T,
                opacity = 0.8,
                visible = T,
                getColor = get_color_to_rgb_array('colour')
            )

            proppoints <- list(
                getPosition = ~ x + y,
                getColor = get_color_to_rgb_array('colour'),
                getFillColor = get_color_to_rgb_array('colour'),
                getRadius = 1000,
                getTooltip = JS("object =>`${object.label}`"),
                stroked = T,
                radiusScale = 8,
                radiusMinPixels = 1.5,
                radiusMaxPixels = 5,
                opacity = 0.8
            )

            proproot <- list(
                getPosition = ~ start_x + start_y,
                getColor = '#000000',
                getFillColor = '#FFFFFF',
                getRadius = 1000,
                getTooltip = "Tree root<br>Epi-id: {{eid}}",
                stroked = T,
                radiusScale = 8,
                radiusMinPixels = 5,
                radiusMaxPixels = 15,
                opacity = 1
            )

            deck <- deckgl(width='100vw', height='100vh', latitude = 25, longitude = 25, zoom = 3,
                           pitch = fifelse(in3D, 60, 0), maxPitch = 89.9,
                           style = list(background = bgcol)) %>%
                add_line_layer(data = ll[, .(start_x, start_y, end_x, end_y, colour, label, linewidth)],
                               properties = proplines) %>%
                add_scatterplot_layer(data = pp[, .(x, y, colour, label)], properties = proppoints) %>%
                add_scatterplot_layer(data = rootpt[, .(start_x, start_y, eid)], properties = proproot) %>%
                add_legend(
                    colors = leg$colour,
                    labels = leg$val,
                    title = '',
                    pos = 'top-left'
                )

        } else {

            proppoints <- list(
                getPosition = ~ x + y,
                getColor = get_color_to_rgb_array('colour'),
                getFillColor = get_color_to_rgb_array('colour'),
                getRadius = 1000,
                stroked = T,
                radiusScale = 8,
                radiusMinPixels = 1.5,
                radiusMaxPixels = 5,
                opacity = 0.8
            )

            proproot <- list(
                getPosition = ~ start_x + start_y,
                getColor = '#000000',
                getFillColor = '#FFFFFF',
                getRadius = 1000,
                stroked = T,
                radiusScale = 8,
                radiusMinPixels = 5,
                radiusMaxPixels = 15,
                opacity = 1
            )

            proplines <- list(
                getSourcePosition = ~ start_x + start_y,
                getTargetPosition = ~ end_x + end_y,
                getWidth = 1,
                pickable = T,
                opacity = 0.8,
                visible = T,
                getColor = get_color_to_rgb_array('colour')
            )

            deck <- deckgl(width='100vw', height='100vh', latitude = 25, longitude = 25, zoom = 3,
                           pitch = fifelse(in3D, 60, 0), maxPitch = 89.9,
                           style = list(background = bgcol)) %>%
                add_line_layer(data = ll[, .(start_x, start_y, end_x, end_y, colour)],
                               properties = proplines) %>%
                add_scatterplot_layer(data = pp[, .(x, y, colour)], properties = proppoints) %>%
                add_scatterplot_layer(data = rootpt[, .(start_x, start_y)], properties = proproot) %>%
                add_legend(
                    colors = leg$colour,
                    labels = leg$val,
                    title = '',
                    pos = 'top-left'
                )

        }

    }

    return(deck)
}

tree.from.edge <- function(tedges, sel.eid=123309) {
    from.node <- tedges[eid == sel.eid, to]
    pars <- get.parents(tedges, from.node)
    childs <- get.children(tedges, from.node)
    rbind(pars, childs)
}

tree.from.attribute <- function(tedges, attr.var = 'country', attr.val = 'Australia') {
    te <- tedges[get(attr.var) == attr.val]
    tetips <- te[to.tip == T]
    parents <- get.parents(tedges, tetips$to)
    parents <- unique(parents[, -'lvl'])
    parents
}

upper1st <- function (x, prelower = T) {
    if (is.factor(x)) {
        x0 <- levels(x)
    } else x0 <- as.character(x)
    if (prelower) x0 <- tolower(x0)
    nc <- nchar(x0)
    nc[is.na(nc)] <- 0
    x0[nc > 1] <- sprintf("%s%s", toupper(substr(x0[nc > 1], 1, 1)),
                          substr(x0[nc > 1], 2, nchar(x0[nc > 1])))
    x0[nc == 1] <- toupper(x0[nc == 1])
    if (is.factor(x)) {
        levels(x) <- x0
    } else x <- x0
    return(x)
}

hier.pal <- function(category, subcategory, spread.within = 0.3,
                     chroma = 110, luminance = 70, alpha = 1) {

    cols0 <- data.table(id1 = category, id2 = subcategory)
    cols0[, i := .I]
    setkey(cols0, id1, id2)

    cols <- cols0[, .N, .(id1, id2)]

    ncats <- uniqueN(cols$id1)
    steps <- seq(0, 360, length.out = ncats + 1)
    diff <- steps[2]-steps[1]
    steps <- steps + diff / 2

    steps <- head(steps, ncats)
    names(steps) <- unique(cols$id1)
    cols[, step := steps[id1]]

    spread <- diff * spread.within / 2
    cols[, offset := seq(-spread, spread, length.out = .N), id1]
    cols[, hue := step + offset]

    cols[, c := chroma + offset]
    cols[, l := luminance + offset]

    cols[, col := hcl(h = hue, c = c, l = l, alpha = alpha)]

    setorder(cols0, i)
    return(cols[cols0, col, on = c('id1', 'id2')])
}


#-------------------------------------------------------------------------------
# Licence:
# Copyright (c) 2012-2017 Luzzi Valerio for Gecosistema S.r.l.
#
# The above copyright notice and this permission notice shall be
# included in all copies or substantial portions of the Software.
#
# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
# EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
# OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
# NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
# HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
# WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
# FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
# OTHER DEALINGS IN THE SOFTWARE.
#
# Name:
# Purpose:     Kriging
#
# Author:      Luzzi Valerio
#
# Created:     05/09/2017
#-------------------------------------------------------------------------------

#SRS =  "+proj=tmerc +lat_0=0 +lon_0=9 +k=0.9996 +x_0=500092 +y_0=-3999800 +ellps=WGS84 +towgs84=0,0,0,0,0,0,0 +units=m +no_defs"
#
#Default SRS= epsg:3857 if not defined in shape
SRS = "+proj=merc +a=6378137 +b=6378137 +lat_ts=0.0 +lon_0=0.0 +x_0=0.0 +y_0=0 +k=1.0 +units=m +nadgrids=@null +wktext  +no_defs"
#------------------------------------------------------------------------------
#	string functions
#------------------------------------------------------------------------------
len<-function(arr)length(arr)
contains<-function(text,search){return(length(grep(search,text))>0)}
alltrim <- function (text) gsub("^\\s+|\\s+$", "",text)
upper<-function(text)toupper(text)
lower<-function(text)tolower(text)
left<-function(text,n)substr(text,1,n)
juststem<-function(text) sub("^([^.]*).*", "\\1", basename(text))
justpath<-function(text)dirname(text)
justext<-function(text) substr(text,nchar(text)-2,nchar(text))
forceext<-function(text,ext) sub("^([^.]*).*", paste("\\1",ext,sep="."), text)
mkdirs<-function(text)dir.create(text,recursive=TRUE,showWarnings = FALSE)
isDate<-function(text){res = tryCatch(length(as.Date(text))>0,error=function(e){return(FALSE)});return(res)}
logger<-function(text){f=file("log.txt",open="at");writeLines(text,f);print(text);close(f);}
progression<-function(text,perc){f=file("interp.progress",open="at");writeLines(text,f);print(text);close(f);}

#------------------------------------------------------------------------------
#	CreateMask
#------------------------------------------------------------------------------
CreateMask<-function(piezo,buffer=200,pixelsize=10){

	bbox = bbox(piezo)
	minx = bbox[1]-buffer
	miny = bbox[2]-buffer
	maxx = bbox[3]+buffer
	maxy = bbox[4]+buffer
	x= seq(minx,maxx,pixelsize)
	y= seq(miny,maxy,pixelsize)

	grid = expand.grid(X=x,Y=y)
	grid$Z = 0.0
	gridded(grid)=~X+Y
	proj4string(grid)=proj4string(piezo)
	#writeGDAL(grid["Z"],"buffer.tif")
	return(grid)
}

#------------------------------------------------------------------------------
#	DetectFormulaUK -  Formula for universal Kriging
#------------------------------------------------------------------------------
DetectFormulaUK <- function( prec ){

	#Creo la formula per l'Universal Kriging
	#Cerco il nome della variabile dipendente
	VALUE = "VALUE"
	cn  = names( prec )  #Nomi dei campi
	candidates = c("VALUE","value")
	for(varname in candidates){
		if ( isTRUE(grep(varname,cn)) ){
			VALUE = varname
			break
		}
	}

	#Creo la formula per l'Universal Kriging
	cn = cn[cn!=VALUE] #Rimuovo "VALUE" non deve comparire a dx nella formula
	f = paste(cn,collapse="+")
	f = paste(VALUE,"~",f)
	f = as.formula(f)
	return(f)
}

#------------------------------------------------------------------------------
#	Kriging | IDW
#------------------------------------------------------------------------------
Kriging <- function( fileshp, filetif="", sformula="VALUE~1", type ="AUTO", pixelsize=100, psill=1, range=900, nugget=1, buffer=0, RemoveNegativeValues=FALSE)
{
    prec = readOGR(fileshp,juststem(fileshp))
    if (is.na(proj4string(prec)))
        proj4string(prec) = CRS(SRS)

	print(paste("Number of points to krige",length(prec)))

	dem <- CreateMask(prec, buffer, pixelsize)
	xy  <- as.data.frame(coordinates(dem))
	dem@data$x<-xy$X
	dem@data$y<-xy$Y

	#Rinomino la banda1 in z
	colnames(dem@data)[1]="z"

	#fieldname (in genere VALUE)
	formula   = as.formula(sformula)
	fieldname = alltrim(strsplit(sformula,"~")[[1]][1])

	#Remove na from prec$VALUE
	prec<-prec[!is.na(prec[[fieldname]]),]

	#Overlay prendo il valori nei punti delle stazioni
	ov<-over(prec,dem)
	prec$x <- ov$x
	prec$y <- ov$y
	prec$z <- ov$z

	#print(prec)

	#UniversalKriging
	if (type =="UK"){
	  # trend model
	  #sformula ="VALUE~X+Y+Z"
	  #formula = as.formula(sformula)    #else fm = DetectFormulaUK(prec@data)
	  lm.prec <- lm(fm, prec)
	  formula_optimal <-step(lm.prec)
	  residui = residuals(fm)

	  null.vgm <- vgm(var(residui), "Sph", sqrt(areaSpatialGrid(dem))/4, nugget=0) # initial parameters
	  vgm_r    <- fit.variogram(variogram(residui~1, prec) ,model=null.vgm)
	  prec_ok  <- krige(as.formula(formula_optimal), locations=prec, newdata=dem, model=vgm_r)
	  prediction = prec_ok[1]
	}

	#Automap
	if (type == "AUTO"){
	  library(automap)
		prec_ok <-autoKrige(formula,prec,dem)
		prec_ok = prec_ok$krige_output
		prediction = prec_ok[1]
	}
	#Ordinary Kriging
	if ( type =="OK"){
	  #psill,range,nugget are auto calculated by fitting the variogram

	  #this are initial parameters to suggest an initial variogram model to fit.variogram algorithm
    psill = var(prec[[fieldname]]) #variance of prec$VALUE
    range = sqrt(areaSpatialGrid(dem))/4
    nugget = 0

		null.vgm = vgm(psill, "Sph", range, nugget)
		vgm_optimal = fit.variogram(variogram(formula, prec), model=null.vgm )
		#vgm_optimal is the best variogram model that fit the empirical variogram data

		#print(vgm_optimal)
		#print("-----------------------")

		prec_ok <- krige(formula, locations=prec, newdata=dem, model=vgm_optimal)
		prediction = prec_ok[1]
	}
	#Ordinary Kriging
	if ( type =="OK-ADVANCED"){
	  #psill,range,nugget are chosen from user passed by arg
	  vgm_optimal<- vgm(psill, "Sph", range, nugget)

	  print(vgm_optimal)
	  print("-----------------------")

		prec_ok <- krige(formula, locations=prec, newdata=dem, model=vgm_optimal)
		prediction = prec_ok[1]
	}
	#Inverse Distance
	if( type =="IDW2"){
    prec_ok <- idw(formula, prec, dem,idp=2.0,maxdist=Inf)
    prediction = prec_ok[1]
	}
	mkdirs(justpath(filetif))

	#Remove negative values!!!!
	if (RemoveNegativeValues){
		prediction@data[prediction@data<0]=0}

	writeGDAL(prediction,filetif)
	return(filetif)
}

#------------------------------------------------------------------------------
#	Main
#------------------------------------------------------------------------------
Main <- function(){
  #Suppress Warning
  options(warn=-1)

	#Getting command arguments
	args <- commandArgs(trailingOnly = TRUE)
	res = FALSE

	#load required libraries
	suppressPackageStartupMessages(library(rgdal))
	library(sp)
	library(rgdal)
	library(gstat)
	#library(tools)

	#Test
	filetif = ""
	if (length(args)==0){

		setwd("c:\\Users\\vlr20\\Dektop\\FeFlow\\results")
		fileshp		= "okrige-759066-2015-08-01.shp"
		filetif   = forceext(fileshp,"tif")

		method = "OK"
		sformula ="value~1"
		psill = 1
		range = 900
		nugget = 1
		pixelsize=10
		buffer = 5000
		filetif = Kriging(fileshp, filetif, sformula, method, pixelsize, psill, range, nugget, buffer, RemoveNegativeValues=FALSE)
	}
	if (length(args)==10){

		Sys.getenv()

		fileshp		  = Sys.getenv("FILESHP")
		filetif		  = Sys.getenv("FILETIF")
		sformula      = Sys.getenv("SFORMULA")
		method		  = Sys.getenv("METHOD")  #AUTO|UK|UK-AutoKrige|OK|OK-ADVANCED|IDW2
		pixelsize     = as.numeric(Sys.getenv("PIXELSIZE"))

		psill         = as.numeric(Sys.getenv("PSILL"))
		range         = as.numeric(Sys.getenv("RANGE"))
		nugget        = as.numeric(Sys.getenv("NUGGET"))
		buffer        = as.numeric(Sys.getenv("BUFFER"))
		RemoveNegativeValues = as.logical(Sys.getenv("REMOVENEGATIVEVALUES")) #remove non-sense negative values caused by interpolation

		#print(fileshp)
		#print(method)
		#print(pixelsize)
		#print(sformula)
		#print(RemoveNegativeValues)
		#comment next 2 lines
		# ...
		#pixelsize	=50
		#Pay attention here!!
		filetif = Kriging(fileshp, filetif, sformula, method, pixelsize, psill, range, nugget, buffer, RemoveNegativeValues)
	}

	#res = paste('{"success":TRUE,"filename":"',filetif,'"}',sep="")
	return(filetif)
}

#------------------------------------------------------------------------------
#	Main-loop launch
#------------------------------------------------------------------------------
##libray = "D:\\Program Files (x86)\\SICURA\\apps\\common\\bin\\R\\R-3.3.2\\library"
##install.packages("sp",     lib=libray)
##install.packages("rgdal",  lib=libray)
##install.packages("gstat",  lib=libray)
##install.packages("automap",  lib=libray)
##install.packages("tools",  lib=libray)
print(Main())


# 3. faza: Vizualizacija podatkov

# Funkcija za prikaz napredka discipline

Graf_napredka <- function(razdalja, bazen){
  ggplot(podatki %>% filter(Distance == razdalja, Pool == bazen) %>%
           mutate(zaokrozeni_datumi=Swim_date-day(Swim_date)+1) %>%
           group_by(zaokrozeni_datumi) %>% summarise(Time=min(Time)),
         aes(x=zaokrozeni_datumi, y=Time)) +
    geom_line() + ylab("Čas plavanja") + xlab("Datum")
}

# Funkcija za prikaz napredka plavalca pri neki disciplini

Graf_plavalca <- function(razdalja, bazen, ime){
  ggplot(podatki %>% filter(Distance == razdalja, Pool == bazen, Name == ime) %>%
           mutate(zaokrozeni_datumi=Swim_date-day(Swim_date)+1) %>%
           group_by(zaokrozeni_datumi) %>% summarise(Time=min(Time)),
         aes(x=zaokrozeni_datumi, y=Time), colour = "steelblue", size = 1) +
    geom_line() + ylab("Swim Time") + xlab("Date")
}

# Primerjava kratkih in dolgih bazenov

Graf_LCM_vs_SCM <- function(razdalja){
  SCM_podatki <- podatki %>% filter(Distance == razdalja, Pool == "SCM") %>%
    mutate(zaokrozeni_datumi=Swim_date-day(Swim_date)+1) %>%
    group_by(zaokrozeni_datumi) %>% summarise(Time=min(Time)) %>%
    mutate(Pool="SCM")

  LCM_podatki <- podatki %>% filter(Distance == razdalja, Pool == "LCM") %>%
    mutate(zaokrozeni_datumi=Swim_date-day(Swim_date)+1) %>%
    group_by(zaokrozeni_datumi) %>% summarise(Time=min(Time)) %>%
    mutate(Pool="LCM")

  ime_grafa <- paste("Primerjava dolgih in kratkih bazenov pri", as.character(razdalja), "metrov delfin")

  LCM_vs_SCM <- rbind(SCM_podatki, LCM_podatki)

  ggplot(LCM_vs_SCM) +
    geom_line() +
    aes(x = zaokrozeni_datumi, y = Time, col = Pool) +
    ylab("Čas plavanja [sekunde]") + xlab("Datum") + labs(title = ime_grafa)
}

# Osebni rekordi plavalca

Osebni_rekordi_plavalca <- function(ime){
  vsi_casi <- podatki %>% filter(Name == ime)
  osebni_rekordi <- vsi_casi %>% group_by(Distance, Pool) %>% summarise(Time=min(Time))
  osebni_rekordi
}

# Najboljse tekme (stevilo novih casov na tekmi) po disciplini

Najboljse_tekme <- function(dolzina, bazen){
  ggplot(as.data.frame(table((podatki %>%
                                filter(Distance == dolzina, Pool == bazen)) %>%
                               group_by(Meet_name)%>%
                               summarise(Meet_name))),
         aes(x=reorder(Var1, Freq), y=Freq)) +
    geom_bar(stat = "identity", fill="steelblue") +
    coord_flip() +
    labs(x = "Meet name", y = "Number of top 200 results")
}

# Koliko tekem je bilo kje

tekme_na_drzavo <- as.data.frame(table(dogodki %>% group_by(Meet_country) %>% summarise(Meet_country)))

graf_tekme_na_drzavo <- ggplot(tekme_na_drzavo,
                          aes(x=reorder(Var1, -Freq), y=Freq)) +
  geom_bar(stat = "identity", fill="steelblue") +
  labs(x = "Country", y = "Number of competitions")

# Uvozim zemljevid za število tekem

zemljevid <- uvozi.zemljevid("https://www.naturalearthdata.com/http//www.naturalearthdata.com/download/110m/cultural/110m_cultural.zip",
                             "ne_110m_admin_0_countries", encoding="UTF-8") %>%
  fortify()

colnames(zemljevid)[12] <- "Var1"

zemljevid$Var1 <- gsub("US1", "USA", zemljevid$Var1)
zemljevid$Var1 <- gsub("AU1", "AUS", zemljevid$Var1)
zemljevid$Var1 <- gsub("COG", "CGO", zemljevid$Var1)
zemljevid$Var1 <- gsub("CH1", "CHN", zemljevid$Var1)
zemljevid$Var1 <- gsub("HRV", "CRO", zemljevid$Var1)
zemljevid$Var1 <- gsub("DN1", "DEN", zemljevid$Var1)
zemljevid$Var1 <- gsub("FI1", "FIN", zemljevid$Var1)
zemljevid$Var1 <- gsub("FR1", "FRA", zemljevid$Var1)
zemljevid$Var1 <- gsub("GB1", "GBR", zemljevid$Var1)
zemljevid$Var1 <- gsub("DEU", "GER", zemljevid$Var1)
zemljevid$Var1 <- gsub("GRC", "GRE", zemljevid$Var1)
zemljevid$Var1 <- gsub("IDN", "INA", zemljevid$Var1)
zemljevid$Var1 <- gsub("IS1", "ISN", zemljevid$Var1)
zemljevid$Var1 <- gsub("MYS", "MAS", zemljevid$Var1)
zemljevid$Var1 <- gsub("NL1", "NED", zemljevid$Var1)
zemljevid$Var1 <- gsub("NZ1", "NZL", zemljevid$Var1)
zemljevid$Var1 <- gsub("ZAF", "RSA", zemljevid$Var1)
zemljevid$Var1 <- gsub("CHE", "SUI", zemljevid$Var1)
zemljevid$Var1 <- gsub("ARE", "UAE", zemljevid$Var1)

zemljevid_tekem <- ggplot() +
  geom_polygon(data=right_join(tekme_na_drzavo, zemljevid, by="Var1"),
               aes(x=long, y=lat, group=group, fill=Freq)) +
  xlab("") +
  ylab("") +
  ggtitle("Zemljevid tekem po državah") +
  theme(axis.title=element_blank(), axis.text=element_blank(),
        axis.ticks=element_blank(), panel.background = element_blank()) +
  scale_fill_gradient(low = '#FCDADA', high='#970303', limits=c(1,35)) +
  labs(fill="Število tekem")

# plot(zemljevid_tekem)

# Najštevilčnejše reprezentance delfinistov

stevilo_plavalcev_iz_posamicnih_drzav <- as.data.frame(table(plavalci %>% group_by(Country) %>% summarise(Country)))

graf_stevila_plavalcev_iz_posamicnih_drzav <- ggplot(stevilo_plavalcev_iz_posamicnih_drzav,
                                                     aes(x=reorder(Var1, Freq), y=Freq)) +
  geom_bar(stat = "identity", fill="steelblue") +
  geom_text(aes(label=Freq)) +
  labs(x = "Country", y = "Number of top 200 swimmers") +
  coord_flip()

# Uvozim zemljevid za število najboljših delfinistov

zemljevid2 <- uvozi.zemljevid("https://www.naturalearthdata.com/http//www.naturalearthdata.com/download/110m/cultural/110m_cultural.zip",
                             "ne_110m_admin_0_countries", encoding="UTF-8") %>%
  fortify()

colnames(zemljevid2)[11] <- "Var1"

zemljevid2$Var1 <- gsub("United Kingdom", "Great Britain", zemljevid2$Var1)
zemljevid2$Var1 <- gsub("Russia", "Russian Federation", zemljevid2$Var1)
zemljevid2$Var1 <- gsub("Republic of Serbia", "Serbia", zemljevid2$Var1)

zemljevid_stevilo_delfinistov <- ggplot() +
  geom_polygon(data=right_join(stevilo_plavalcev_iz_posamicnih_drzav, zemljevid2, by="Var1"),
               aes(x=long, y=lat, group=group, fill=Freq)) +
  xlab("") +
  ylab("") +
  ggtitle("Zemljevid števila delfinistov iz držav") +
  theme(axis.title=element_blank(), axis.text=element_blank(),
        axis.ticks=element_blank(), panel.background = element_blank()) +
  scale_fill_gradient(low = '#FCDADA', high='#970303', limits=c(1,20)) +
  labs(fill="Število delfinistov")

# Starost rekorderjev

t <- ((right_join(podatki, plavalci, by="Name")) %>%
        filter(Points>=1000)) %>%
  select(Name, Swim_date, Birth_date)

graf_starosti_rekorderjev <- ggplot(as.data.frame(table(floor((t$Swim_date - t$Birth_date)/365.25))),
                                    aes(x=Var1, y=Freq)) +
  geom_bar(stat = "identity", fill = "steelblue") +
  labs(x = "Starost", y = "Število plavalcev") +
  labs(title = "Graf starosti plavalcev ko so odplavali svetovni rekord")


# W SA i GA jest inna filozofia funkcji_oceniajacej: w SA ma byc jak najmniejsza, w GA ma byc jak najwieksza

# Zeby to zadzialalo, wczesniej trzeba zrobic:
# install.packages("GenSA")
library(GenSA)

# Do zmiennej "poznan" wczytujemy dane z pliku CSV
setwd('/')
poznan <- read.csv(file = 'poznan.csv')

#liczba obos
N <- 65

#plec i wiek
N_WOMAN18 <- 2
N_MAN18 <- 2
N_WOMAN25 <- 9
N_MAN25 <- 8
N_WOMAN40 <- 14
N_MAN40 <- 12
N_WOMAN65 <- 11
N_MAN65 <- 7

#wyksztalcenie
N_PRIMARY <- 9
N_MEDIUM <- 35
N_HIGHER <- 21

#stosunek do zmian kliematu skala 5-stopniowa
NC_1 <- 10
NC_2 <- 2
NC_3 <- 14
NC_4 <- 11
NC_5 <- 28

#osiedle
N_A_1 <- 1
N_A_2 <- 2
N_A_3 <- 1
N_A_4 <- 1
N_A_5 <- 1
N_A_6 <- 2
N_A_7 <- 3
N_A_8 <- 2
N_A_9 <- 1
N_A_10 <- 2
N_A_11 <- 1
N_A_12 <- 1
N_A_13 <- 1
N_A_14 <- 1
N_A_15 <- 1
N_A_16 <- 1
N_A_17 <- 1
N_A_18 <- 2
N_A_19 <- 2
N_A_20 <- 2
N_A_21 <- 1
N_A_22 <- 1
N_A_23 <- 1
N_A_24 <- 3
N_A_25 <- 1
N_A_26 <- 3
N_A_27 <- 1
N_A_28 <- 3
N_A_29 <- 1
N_A_30 <- 1
N_A_31 <- 1
N_A_32 <- 1
N_A_33 <- 1
N_A_34 <- 3
N_A_35 <- 2
N_A_36 <- 1
N_A_37 <- 1
N_A_38 <- 3
N_A_39 <- 2
N_A_40 <- 1
N_A_41 <- 2
N_A_42 <- 2

# ROZMIAR_DANYCH (dla zbioru poznan)
ROZMIAR_DANYCH <- nrow(poznan)

funkcja_oceniajaca <- function(v,b) {

  ret <- 0

  #zapobieganie duplikatom
  if(any(duplicated(poznan$ID[v]))){
    ret <- 99999999
  }else{

    # Liczymy ile jest "man/woman" i zakresy wiekowe
    man18 <- 0
    woman18 <- 0
    man25 <- 0
    woman25 <- 0
    man40 <- 0
    woman40 <- 0
    man65 <- 0
    woman65 <- 0

    #liczniki wyksztalcenia
    primary <- 0
    medium <- 0
    higher <- 0

    #liczniki stosunku klimatu
    c1 <- 0
    c2 <- 0
    c3 <- 0
    c4 <- 0
    c5 <- 0

    #liczniki osiedla
    a1 <- 0
    a2 <- 0
    a3 <- 0
    a4 <- 0
    a5 <- 0
    a6 <- 0
    a7 <- 0
    a8 <- 0
    a9 <- 0
    a10 <- 0
    a11 <- 0
    a12 <- 0
    a13 <- 0
    a14 <- 0
    a15 <- 0
    a16 <- 0
    a17 <- 0
    a18 <- 0
    a19 <- 0
    a20 <- 0
    a21 <- 0
    a22 <- 0
    a23 <- 0
    a24 <- 0
    a25 <- 0
    a26 <- 0
    a27 <- 0
    a28 <- 0
    a29 <- 0
    a30 <- 0
    a31 <- 0
    a32 <- 0
    a33 <- 0
    a34 <- 0
    a35 <- 0
    a36 <- 0
    a37 <- 0
    a38 <- 0
    a39 <- 0
    a40 <- 0
    a41 <- 0
    a42 <- 0

    for (i in 1:length(v)) {

      if (poznan$GenderAge[v[i]] == "man18-24") {
        man18 <- man18+1
      } else if (poznan$GenderAge[v[i]] == "woman18-24") {
        woman18 <- woman18+1
      } else if (poznan$GenderAge[v[i]] == "man25-39") {
        man25 <- man25+1
      } else if (poznan$GenderAge[v[i]] == "woman25-39") {
        woman25 <- woman25+1
      } else if (poznan$GenderAge[v[i]] == "man40-64") {
        man40 <- man40+1
      } else if (poznan$GenderAge[v[i]] == "woman40-64") {
        woman40 <- woman40+1
      } else if (poznan$GenderAge[v[i]] == "man65+") {
        man65 <- man65+1
      } else if (poznan$GenderAge[v[i]] == "woman65+") {
        woman65 <- woman65+1
      } else {

      }

      if (poznan$Education[v[i]] == "primary") {
        primary <- primary+1
      } else if (poznan$Education[v[i]] == "medium") {
        medium <- medium+1
      } else if (poznan$Education[v[i]] == "higher") {
        higher <- higher+1
      } else {

      }

      if (poznan$climate[v[i]] == "1") {
        c1 <- c1+1
      } else if (poznan$climate[v[i]] == "2")  {
        c2 <- c2+1
      } else if (poznan$climate[v[i]] == "3")  {
        c3 <- c3+1
      } else if (poznan$climate[v[i]] == "4")  {
        c4 <- c4+1
      } else if (poznan$climate[v[i]] == "5")  {
        c5 <- c5+1
      }

      if (poznan$area[v[i]] == "1") {
        a1 <- a1+1
      }else if(poznan$area[v[i]] == "2") {
        a2 <- a2+1
      }else if(poznan$area[v[i]] == "3") {
        a3 <- a3+1
      }else if(poznan$area[v[i]] == "4") {
        a4 <- a4+1
      }else if(poznan$area[v[i]] == "5") {
        a5 <- a5+1
      }else if(poznan$area[v[i]] == "6") {
        a6 <- a6+1
      }else if(poznan$area[v[i]] == "7") {
        a7 <- a7+1
      }else if(poznan$area[v[i]] == "8") {
        a8 <- a8+1
      }else if(poznan$area[v[i]] == "9") {
        a9 <- a9+1
      }else if(poznan$area[v[i]] == "10") {
        a10 <- a10+1
      }else if(poznan$area[v[i]] == "11") {
        a11 <- a11+1
      }else if(poznan$area[v[i]] == "12") {
        a12 <- a12+1
      }else if(poznan$area[v[i]] == "13") {
        a13 <- a13+1
      }else if(poznan$area[v[i]] == "14") {
        a14 <- a14+1
      }else if(poznan$area[v[i]] == "15") {
        a15 <- a15+1
      }else if(poznan$area[v[i]] == "16") {
        a16 <- a16+1
      }else if(poznan$area[v[i]] == "17") {
        a17 <- a17+1
      }else if(poznan$area[v[i]] == "18") {
        a18 <- a18+1
      }else if(poznan$area[v[i]] == "19") {
        a19 <- a19+1
      }else if(poznan$area[v[i]] == "20") {
        a20 <- a20+1
      }else if(poznan$area[v[i]] == "21") {
        a21 <- a21+1
      }else if(poznan$area[v[i]] == "22") {
        a22 <- a22+1
      }else if(poznan$area[v[i]] == "23") {
        a23 <- a23+1
      }else if(poznan$area[v[i]] == "24") {
        a24 <- a24+1
      }else if(poznan$area[v[i]] == "25") {
        a25 <- a25+1
      }else if(poznan$area[v[i]] == "26") {
        a26 <- a26+1
      }else if(poznan$area[v[i]] == "27") {
        a27 <- a27+1
      }else if(poznan$area[v[i]] == "28") {
        a28 <- a28+1
      }else if(poznan$area[v[i]] == "29") {
        a29 <- a29+1
      }else if(poznan$area[v[i]] == "30") {
        a30 <- a30+1
      }else if(poznan$area[v[i]] == "31") {
        a31 <- a31+1
      }else if(poznan$area[v[i]] == "32") {
        a32 <- a32+1
      }else if(poznan$area[v[i]] == "33") {
        a33 <- a33+1
      }else if(poznan$area[v[i]] == "34") {
        a34 <- a34+1
      }else if(poznan$area[v[i]] == "35") {
        a35 <- a35+1
      }else if(poznan$area[v[i]] == "36") {
        a36 <- a36+1
      }else if(poznan$area[v[i]] == "37") {
        a37 <- a37+1
      }else if(poznan$area[v[i]] == "38") {
        a38 <- a38+1
      }else if(poznan$area[v[i]] == "39") {
        a39 <- a39+1
      }else if(poznan$area[v[i]] == "40") {
        a40 <- a40+1
      }else if(poznan$area[v[i]] == "41") {
        a41 <- a41+1
      }else if(poznan$area[v[i]] == "42") {
        a42 <- a42+1
      }
    }

    #do wieku i plci dodana jest waga aby zwiekszyc nacisk na te kryteria
    ret <- ret + (N_MAN18-man18)^2*10 + (N_WOMAN18-woman18)^2*10 + (N_MAN25-man25)^2*10 + (N_WOMAN25-woman25)^2*10 + (N_MAN40-man40)^2*10 + (N_WOMAN40-woman40)^2*10 + (N_MAN65-man65)^2*10 + (N_WOMAN65-woman65)^2*10 + (N_PRIMARY-primary)^2 + (N_MEDIUM-medium)^2 + (N_HIGHER-higher)^2 + (NC_1 -c1)^2 +(NC_2-c2)^2+(NC_3-c3)^2+(NC_4-c4)^2+(NC_5-c5)^2+(N_A_1-a1)^2+(N_A_2-a2)^2+(N_A_3-a3)^2+(N_A_4-a4)^2+(N_A_5-a5)^2+(N_A_6-a6)^2+(N_A_7-a7)^2+(N_A_8-a8)^2+(N_A_9-a9)^2+(N_A_10-a10)^2+(N_A_11-a11)^2+(N_A_12-a12)^2+(N_A_13-a13)^2+(N_A_14-a14)^2+(N_A_15-a15)^2+(N_A_16-a16)^2+(N_A_17-a17)^2+(N_A_18-a18)^2+(N_A_19-a19)^2+(N_A_20-a20)^2+(N_A_21-a21)^2+(N_A_22-a22)^2+(N_A_23-a23)^2+(N_A_24-a24)^2+(N_A_25-a25)^2+(N_A_26-a26)^2+(N_A_27-a27)^2+(N_A_28-a28)^2+(N_A_29-a29)^2+(N_A_30-a30)^2+(N_A_31-a31)^2+(N_A_32-a32)^2+(N_A_33-a33)^2+(N_A_34-a34)^2+(N_A_35-a35)^2+(N_A_36-a36)^2+(N_A_37-a37)^2+(N_A_38-a38)^2+(N_A_39-a39)^2+(N_A_40-a40)^2+(N_A_41-a41)^2+(N_A_42-a42)^2

  }

  if (b) {
    #prezentacja wynikow
    print( poznan$Code[v] )
    print( cat('man18=', man18, ' woman18=', woman18,'man25=', man25, ' woman25=', woman25,'man40=', man40, ' woman40=', woman40,'man65=', man65, ' woman65=', woman65, ' primary=', primary, ' medium=', medium, ' higher=', higher,' climate1=',c1,' climate2=',c2,' climate3=',c3, ' cliamte4=',c4, ' climate5=',c5,' area1=',a1,' area2=',a2,' area3=',a3,' area4=',a4,' area5=',a5,' area6=',a6,' area7=',a7,' area8=',a8,' area9=',a9,' area10=',a10,' area11=',a11,' area12=',a12,' area13=',a13,' area14=',a14,' area15=',a15,' area16=',a16,' area17=',a17,' area18=',a18,' area19=',a19,' area20=',a20,' area21=',a21,' area22=',a22,' area23=',a23,' area24=',a24,' area25=',a25,' area26=',a26,' are27=',a27,' area28=',a28,' area29=',a29,' area30=',a30,' area31=',a31,' area32=',a32,' area33=',a33,' area34=',a34,' area35=',a35,' area36=',a36,' area37=',a37,' area38=',a38,' area39=',a39,' area40=',a40,' area41=',a41,' area42=',a42) )
   #zapis wynikow do pliku
    write.csv(cbind(poznan$ID[v],poznan$Code[v]),'wynik.csv',row.names = FALSE)
  }

  ret
}

# Funkcja oceniajaca bedzie sluzyla do optymalizacji rozwiazania. Chcemy, zeby miala jak najnizsza wartosc.
# Argumentem jest wektor danych (lista ID osob) - poniewaz nam chodzi o zbior 65 osob, wiec poprzez wartosc funkcji
# musimy wykluczyc wektory, gdzie ID sie powtarzaja (damy im bardzo wysoka wartosc).
# Przyjmiemy, ze ciag elementow wektora (czyli ID osob) musi byc rosnacy (co nam zapewnia roznowartosciowosc).

# Bez "as.numeric" wywraca sie z komunikatem "REAL() can only be applied..."
WYNIK <- GenSA(par=as.numeric(sample(1:N)*ROZMIAR_DANYCH/N), fn=funkcja_oceniajaca, lower=as.numeric(seq(1,N)), upper=as.numeric(seq(ROZMIAR_DANYCH-N+1,ROZMIAR_DANYCH)), FALSE, control=list(max.time=1440,smooth=FALSE,verbose=TRUE,temperature=50.0))
print(WYNIK)

#wynik
funkcja_oceniajaca(WYNIK$par, TRUE)


#
# Exemplo 3
#

# atribui valores para x1 e x2
x1 <- 0.3815
x2 <- 123456789015
# cálculo 1
resultado1 <- (x1 + x2) - x2
resultado1
# cálculo 2
resultado2 <- x1 + (x2 - x2)
resultado2


#==============================================================================#
# This function will place any list of files with any pattern into a vector
# in an object. The way it should be used for the functions on this page
# is to search for .dat files.
#==============================================================================#
getfile <- function(multFile=NULL, pattern=NULL){
# the default option is to grab all of the files in a directory matching a
# specified pattern. If no pattern is set, all files will be listed.
	if (is.null(multFile) || toupper(multFile) == "YES"){
		# this sets the path variable that the user can use to set the path
		# to the files with setwd(x$path), where x is the datastructure
		# this function dumped into.
		path <- sub("(^.+?/).+?\\.[a-z]{3}$", "\\1", file.path(file.choose()))
		if (!is.null(pattern)){
			pat <- pattern
			x <- list.files(path, pattern=pat)
		}
		else {
			x <- list.files(path)
		}
	}
	else {
		# if the user chooses to analyze only one file, a pattern is not needed
		csv <- file.choose()
		path <- sub("(^.+?/).+?\\.[a-z]{3}$", "\\1", file.path(csv))
		csv <- sub("^.+?/(.+?\\.[a-z]{3})$", "\\1", csv)
		x <- csv
	}
	filepath <- list(files=x, path=path)
	return(filepath)
}
#==============================================================================#
# The calculation of the Index of Association and standardized Index of
# Association.
#==============================================================================#
stdIa <- function(x){
#------------------------------------------------------------------------------#
# Testing for valid filetypes
#------------------------------------------------------------------------------#
	if (toupper(.readExt(x)) == "DAT") {
		pop <- read.fstat(x, missing = 0, quiet=T)
	}
	else if (toupper(.readExt(x)) %in% c("STR", "STRU")) {
		pop <- read.structure(x, missing = 0, ask=FALSE, quiet=TRUE)
	}
	else if (toupper(.readExt(x)) == "GTX") {
		pop <- read.genetix(x, missing = 0, quiet=T)
	}
	else if (toupper(.readExt(x)) == "GEN") {
		pop <- read.genepop(x, missing = 0, quiet=T)
	}
	else {
		stop("File ext .dat, .str, .gtx, or .gen expected")
	}
	numAlleles <- length(pop@loc.names)
	numIsolates <- length(pop@ind.names)
	# Creating this number is necessary because it is how the variance is
	# calculated.
	np <- (numIsolates*(numIsolates-1))/2
	# Creation of the datastructures
	if (!exists("Ia.vector")){
		Ia.vector <- NULL
		rbarD.vector <- NULL
		file.vector <- NULL
	}
	D.matrix <- matrix(0, nrow=numIsolates, ncol=numIsolates)
	d.matrix <- D.matrix
	d.vector <- NULL
	d2.vector <- NULL
	vard.vector <- NULL
	vardpair.vector <- NULL
	count <- 0
#--------------------------------------------------------------------------#
# This is the loop for analyzing the pairwise distances at each locus,
# also known as d. These values will be placed into two vectors representing
# the sum of d for each locus and the sum of d^2 for each locus.
#
# This will also calculate D, the pairwise comparison of all isolates over
# all loci.
#--------------------------------------------------------------------------#
	for (loc in names(pop@loc.nall)){
		n <- count + 1
		count <- pop@loc.nall[loc] + count
		m <- count
		#print(paste(n, m, sep=":"))
		for(j in 1:numIsolates){
			# Loop for the rows of the distance matrix
			for(i in 1:numIsolates){
				z <- 0
				# Setting the contraint for the pairwise comparisons by the
				# equation (n(n-1))/2 where n = numIsolates
				if(j < i && i <= numIsolates){
					z <- sum(abs(pop@tab[j,m:n]
								-pop@tab[i,m:n]))
				}
				# The value of z (0, 1, or 2) is pushed into the matrix
				d.matrix[i,j] <- d.matrix[i,j]+z
				# This value is added to the matrix for pairwise comparison
				# of all the isolates over all loci as opposed to each locus
				D.matrix[i,j] <- D.matrix[i,j]+d.matrix[i,j]
			}
		}
		d.vector <- append(d.vector, sum(d.matrix))
		d2.vector <- append(d2.vector, sum(d.matrix^2))
		d.matrix[1:numIsolates,1:numIsolates] <- 0
	}
	rm(d.matrix)
#--------------------------------------------------------------------------#
# Now to begin the calculations. First, set the variance of D
#--------------------------------------------------------------------------#
	varD <- ((sum(D.matrix^2)-((sum(D.matrix))^2)/np))/np
#--------------------------------------------------------------------------#
# Next is to create a vector containing all of the variances of d (there
# will be one for each locus)
#--------------------------------------------------------------------------#
	vard.vector <- ((d2.vector-((d.vector^2)/np))/np)
#--------------------------------------------------------------------------#
# Here the roots of the products of the variances are being produced and
# the sum of those values is taken.
#--------------------------------------------------------------------------#
	for (b in 1:length(d.vector)){
		for (d in 1:length(d.vector)){
			if(b < d && d <= length(d.vector)){
				vardpair <- sqrt(vard.vector[b]*vard.vector[d])
				vardpair.vector <- append(vardpair.vector, vardpair)
			}
		}
	}
#--------------------------------------------------------------------------#
# The sum of the variances necessary for the calculation of Ia is calculated
#--------------------------------------------------------------------------#
	sigVarj <- sum(vard.vector)
	rm(vard.vector)
#--------------------------------------------------------------------------#
# Finally, the Index of Association and the standardized Index of associati-
# on are calculated.
#--------------------------------------------------------------------------#
	Ia <- (varD/sigVarj)-1
	rbarD <- (varD - sigVarj)/(2*sum(vardpair.vector))
	# Prints to screen as loop progresses
	print(paste("File Name:", x, sep=" "))
	print(paste("Index of Association:", Ia, sep=" "))
	print(paste("Standardized Index of Association (rbarD):", rbarD, sep=" "))
	# Saves the values of Ia, rbarD, and the filename into datastructures
	# that will be listed in a dataframe
	file.vector <- append(file.vector, x)
	Ia.vector <- append(Ia.vector, Ia)
	rbarD.vector <- append(rbarD.vector, rbarD)
	Iout <- list(Ia=Ia.vector, rbarD=rbarD.vector, File=file.vector)
	return(as.data.frame(Iout))
}

#==============================================================================#
# This function allows the user to analyze many separate files automatically
#==============================================================================#
stdIa.all <- function(x) {
	Iout <- NULL
	for(a in x){
		Iout <- rbind(Iout, stdIa(a))
	}
	return(Iout)
}

extract.info <- function(x) {
	x$clone <- as.factor(sub("^clone.(\\d{3}.\\d{2}).+?$)","\\1", x$File))
	x$rep <- as.numeric(sub("^clone.+?rep.(\\d{2}).+?$)","\\1", x$File))
	x$pop.size <- as.numeric(sub("^clone.+?pop.(\\d+?).+?$)","\\1", x$File))
	x$sex.rate <- (100-x$clone)/100
	return(x)
}


### Seq-Gen output analysis
### CIR Project
### Advisors: Steve Freedberg, Matthew Richey
### Code by: Suzie Hoops

#######installing packages:
if (!require('seqinr')) {
	install.packages('seqinr', repos="http://cran.rstudio.com/")
	library('seqinr')
}
if (!require('mosaic')) {
	install.packages('mosaic', repos="http://cran.rstudio.com/")
	install.packages('mosaicData', repos="http://cran.rstudio.com/")
	library('mosaic')
}

printf <- function(...) cat(sprintf(...))

##################################################
# We want to compare the two individuals to find a Hamming
# distance between them. That is, how many base pairs differ
# between the two sequences.

# To do this, we must compare each base pair, one at a time.
# Let's make a function for comparing the pieces of the string:
HammingDistance <- function (x, y) {
  # note that the parameters x and y should be
  counter <- 0   # to track the number of base pairs different
  index <- 1     # to keep track of indices in for loop
  xVector <- strsplit(x, "")[[1]]
  yVector <- strsplit(y, "")[[1]]
  for (i in xVector) {
    if (i != yVector[index]) {
      counter <- counter + 1
    }
    index <- index + 1
  }
  return(counter)    # returns number of base pairs that differ
}

HammingDistanceTwoSequences <- function (file1, file2) {
  x <- LoadFileIntoString(file1)
  y <- LoadFileIntoString(file2)
  distance <- HammingDistance(x, y)
  print(distance)
}

LoadFileIntoString <- function (fileName) {
  return(readChar(fileName, file.info(fileName)$size))
}

LoadDataFromFile <- function(fname) {
  ##################################################
  # Generalizing to Larger Files
  # The above code works for a file of only two individuals, but
  # we wish to generalize this so that it can be used for multiple
  # pairs of individuals and store the appropriate data.

  # Note that for now, we will assume that all sequences in a
  # single file have the same length.

  ### First Steps
  # read in the data:
  data <- read.fasta(file=fname, as.string=TRUE)

  # get the number of sequences included in the data
  len <- length(data)

  # create a vector of every other integer up to len for the loop
  list <- seq(1, len, 2)

  # store the original names of the sequences:
  orig_names <- names(data)

  ##################################################
  # We create a for loop to cycle through the pairs and compare
  # each one. The loop will record its findings in a list called `out`.

  # out is initialized with fillers
  out <- seq(1:(len/2))

  # print(data)
  # printf("end\n")

  for (i in list) {
    names(data)[i] <- "indiv1"
    names(data)[i+1] <- "indiv2"
    length <- nchar(data$indiv1[1])
    taxon1 <- substring(data$indiv1[1], seq(1,length,1), seq(1,length,1))
    taxon2 <- substring(data$indiv2[1], seq(1,length,1), seq(1,length,1))
    index <- (i-1)/2 + 1
    out[index] <- HammingDistance(taxon1, taxon2)
  }

  # Now "out" is filled with Hamming distances of all pairs

  ##################################################
  # Simple Statistics from the data:
  avgOfRange <- mean(out)      # average
  minOfRange <- min(out)       # minimum of range
  maxOfRange <- max(out)       # maximum of range
  percent <- (avgOfRange / len)

  printf("avg=%d\n", avgOfRange)
  printf("min=%d\n", minOfRange)
  printf("max=%d\n", maxOfRange)
  printf("percent=%f\n", percent)

  printf("start data\n")
  print(out)    # desired output
}

EstimateGenerations <- function(genlength, percent) {
  ##################################################
  ##################################################
  # Estimating Generations:
  # Assume 2% per million years (standard for cytochrome B)
  # mutation rate. This allows us to calculate a likely divergence
  # time, from which we can estimate generations:

  # divergence time in million years
  divtime <- percent/0.02
  printf("divtime=%d\n", divtime)

  # number of generations (used for seq gen parameters)
  gen <- divtime*1000000/genlength
  printf("gen=%d\n", gen)
}

PrintUsage <- function() {
  write("usage: Rscript hamdis.r <command> <args>", stdout())
  write("commands:", stdout())
  write("  estimate <generation length> <percentage>", stdout())
  write("  calculate <filename> <something else>", stdout())
  write("  distance-between <filename> <filename>", stdout())
  quit()
}

args <- commandArgs(trailingOnly = TRUE)
if (length(args) != 3) {
  PrintUsage()
}

command <- args[1]
if (command == "estimate") {
  genlength <- as.numeric(args[2])
  percent <- as.numeric(args[3])
  EstimateGenerations(genlength, percent)
} else if (command == "calculate") {
  filename <- args[2]
  other <- args[3]
  LoadDataFromFile(filename)
} else if (command == "distance-between") {
  xfilename <- args[2]
  yfilename <- args[3]
  HammingDistanceTwoSequences(xfilename, yfilename)
} else {
  PrintUsage()
}