library(ape)
library(boot)
library(c060)
library(expm)
library(exptest)
library(ggplot2)
library(lubridate)
library(numDeriv)
library(parallel)
library(reshape2)
library(rphastRegression)

#' ## Data loading

tmpf <- function(){
    tmNames <- system("grep ^TreeLikelihood beast/run1/beast-stdout | cut -d\'(\' -f2 | cut -d\')\' -f1 | cut -d\'-\' -f1", inter=TRUE)
    uniquePatterns <- system("grep \"unique pattern count\" beast/run1/beast-stdout | cut -d\' \' -f7", inter=TRUE)
    names(uniquePatterns) <- tmNames
    uniquePatterns
}
uniquePatterns <- tmpf()

tnames <- c('nonsIndel', 'sIndel')
tfiles <- paste0(tnames, '-aligned.fasta-gb.combined.trees')
trees <- lapply(tfiles, read.nexus)

flows <- read.csv("shipment-flows-origins-on-rows-dests-on-columns.csv", row.names=1)

balanceSheet <- read.csv('state-hogBalanceSheetDec2011Dec2012.csv',
                         na.strings='-', row.names=1, colClasses=c(state2='NULL'))
key <- match(rownames(balanceSheet), state.name)
balanceSheet$abb <- state.abb[key]

flowBal <- flows
key <- match(colnames(flowBal), balanceSheet$abb)
bs <- balanceSheet$inshipments[key]
cs <- colSums(flowBal)
for(j in seq(ncol(flowBal))){
    if (cs[j] > 0) flowBal[, j] <- flowBal[, j] * 1000*bs[j]/cs[j]
}
stopifnot(isTRUE(all.equal(sum(abs(colSums(flowBal)[cs > 0] - 1000*bs[cs > 0]), na.rm=TRUE), 0)))

#' ## Tree-model creation

nms <- lapply(trees, attr, which='TipLabel')

tmpf <- function(x) {
    x <- strsplit(x, '_')
    sapply(x, '[', 1)
}
abs <- lapply(nms, tmpf)
sampCounts <- table(unlist(abs))
absF <- factor(unlist(abs))
levs <- levels(absF)
n <- length(unlist(levs))
alph <- LETTERS[seq_len(n)]

absFt <- lapply(abs, factor, levels=levs)
absFt <- lapply(absFt, 'levels<-', value=alph)
alph <- paste(alph, collapse='')
seqs <- lapply(absFt, as.character)
tmpf <- function(x, y) {
    msa(seqs=x, names=y, alphabet=alph)
}
pedvMSA <- mapply(tmpf, seqs, nms, SIMPLIFY=FALSE)

simulationR <- 2
tmpf <- function(x) {
    n <- length(x)
    ind <- sample.int(n, size=simulationR, replace=TRUE)
    x <- x[ind]
    unname(lapply(x, write.tree))
}
treeChar <- lapply(trees, tmpf)

pairs <- expand.grid(to=levs, from=levs)
test <- pairs$from != pairs$to
pairs <- pairs[test,]
pairs <- pairs[, c('from', 'to')]

aggFlow <- function(from, to, sym=TRUE, M=flows){
    tot <- M[from, to]
    if(sym){
        tot <- tot + M[to, from]
    }
    log10(tot + 1)
}

xi <- mapply(aggFlow, from=as.character(pairs$from), to=as.character(pairs$to), sym=TRUE)
predMat <- as.matrix(xi)
rownames(predMat) <- paste0('from', pairs$from, 'to', pairs$to)
colnames(predMat) <- 'log10undirectedFlow'
xi <- mapply(aggFlow, from=as.character(pairs$from), to=as.character(pairs$to), sym=FALSE)
predMat <- cbind(predMat, log10directedFlow=xi)

xi <- mapply(aggFlow, from=as.character(pairs$from), to=as.character(pairs$to),
             MoreArgs=list(sym=TRUE, M=flowBal))
predMat <- cbind(predMat, log10undirectedFlowBal=xi)
xi <- mapply(aggFlow, from=as.character(pairs$from), to=as.character(pairs$to),
             MoreArgs=list(sym=FALSE, M=flowBal))
predMat <- cbind(predMat, log10directedFlowBal=xi)

key <- match(pairs$from, balanceSheet$abb)
xi <- log10(balanceSheet$inventory2012[key])
predMat <- cbind(predMat, log10originInventory=xi)
xi <- log10(balanceSheet$inshipments[key])
predMat <- cbind(predMat, log10originInshipments=xi)
xi <- log10(balanceSheet$marketings[key])
predMat <- cbind(predMat, log10originMarketings=xi)
xi <- log10(balanceSheet$pigCrop[key])
predMat <- cbind(predMat, log10originPigCrop=xi)

key <- match(pairs$to, balanceSheet$abb)
xi <- log10(balanceSheet$inventory2012[key])
predMat <- cbind(predMat, log10destinationInventory=xi)
xi <- log10(balanceSheet$inshipments[key])
predMat <- cbind(predMat, log10destinationInshipments=xi)
xi <- log10(balanceSheet$marketings[key])
predMat <- cbind(predMat, log10destinationMarketings=xi)
xi <- log10(balanceSheet$pigCrop[key])
predMat <- cbind(predMat, log10destinationPigCrop=xi)

xi <- log10(sampCounts[pairs$from])
predMat <- cbind(predMat, log10originSamples=xi)

xi <- log10(sampCounts[pairs$to])
predMat <- cbind(predMat, log10destinationSamples=xi)

bg <- rep(1, n)/n

tmpf <- function(x) {
    lapply(x, tm, subst.mod="UNREST", alphabet=alph, backgd=bg)
}
mods <- lapply(treeChar, tmpf)

assignElement <- function(x, nam, val) {
    tmpf <- function(x) {
        x[[nam]] <- val
        x
    }
    lapply(x, tmpf)
}
mods <- lapply(mods, assignElement, nam='rate.matrix', val=matrix(NA, nrow=n, ncol=n))

##' ## Fit 1-parameter model

getRateMatrix <- function(design.matrix, w){
    scale <- exp(w[1])
    effects <- w[-1]
    stopifnot(ncol(design.matrix) == length(effects))
    eta <- exp(design.matrix %*% effects)
    eta <- eta / mean(eta) * scale
    pos <- 1
    rate.matrix <- matrix(nrow=n, ncol=n)
    for(i in seq_len(n)){
        rowSum <- 0
        for(j in seq_len(n)){
            if (i != j) {
                rate.matrix[i,j] <- eta[pos]
                rowSum <- rowSum + eta[pos]
                pos <- pos + 1
            }
        }
        rate.matrix[i,i] <- -rowSum
    }
    rate.matrix
}

obj <- function(w, msal=pedvMSA, tmlol=mods, x){
    rate.matrix <- getRateMatrix(x, w)
    tmlol <- lapply(tmlol, assignElement, nam='rate.matrix', val=rate.matrix)
    tmpf <- function(x, tmlist) {
        treeLogLikGivenMSA <- function(tm) likelihood.msa(x=x, tm=tm)
        sapply(tmlist, treeLogLikGivenMSA)
    }
    ll <- mapply(tmpf, msal, tmlol)
    if(!is.null(dim(ll))){
        ll <- rowSums(ll)
        scale <- max(ll)
        ll <- ll - scale
        probs <- exp(ll)
        ll <- log(mean(probs)) + scale
    } else if(length(ll) > 1){
        ll <- sum(ll)
    }
    ll
}

obj2 <- function(w, x, y){
    msal <- y$msal
    tmlol <- y$tmlol
    rate.matrix <- getRateMatrix(x, w)
    tmlol <- lapply(tmlol, assignElement, nam='rate.matrix', val=rate.matrix)
    tmpf <- function(xx, tmlist) {
        treeLogLikGivenMSA <- function(tm) likelihood.msa(x=xx, tm=tm)
        sapply(tmlist, treeLogLikGivenMSA)
    }
    ll <- mapply(tmpf, msal, tmlol)
    if(!is.null(dim(ll))){
        ll <- rowSums(ll)
        scale <- max(ll)
        ll <- ll - scale
        probs <- exp(ll)
        ll <- log(mean(probs)) + scale
    } else if(length(ll) > 1){
        ll <- sum(ll)
    }
    ll
}

#' ## Fit 2-parameter models

x <- scale(predMat)
x[is.na(x)] <- 0

preds <- list(directed='log10directedFlow', undirected='log10undirectedFlow')
tmpf <- function(preds){
    ret <- as.matrix(x[, preds])
    colnames(ret) <- preds
    ret
}
dMats <- lapply(preds, tmpf)

tmpf <- function(dMat){
    optim.rphast(obj, x=dMat, par=c(-1,0), lower=c(-4,-2), upper=c(2,2))
}
ans <- lapply(dMats, tmpf)

objNull <- function(scale, x) obj(c(scale, 0), x=dMats[[1]])
ans[['null']] <- optimize(objNull, interval=c(-4,2), x=dMats[[1]], maximum=TRUE)

#' ## Simulations of trees conditional on a sampling configuration

getSampleConfig <- function(nm, levs, genTime=as.numeric(ddays(7))){
    splt <- strsplit(nm, split='_')
    tmpf <- function(x) match(x[[1]], levs)
    popIds <- sapply(splt, tmpf)
    tmpf <- function(x) dmy(x[[2]])
    tipDates <- sapply(splt, tmpf)
    sTimes <- max(tipDates) - tipDates
    sGens <- floor(sTimes / genTime)
    tab <- table(sGens, popIds)
    nSamps <- rep(1, length=length(sGens))
    list(ns=nSamps, sg=sGens, sp=popIds)
}

treesim <- function(N=100, nSamples=2, samplingGens=0, samplingPops=1,
                    migProbs=matrix(1, ncol=1, nrow=1), sampleLabels=NULL){
    nPops <- length(N)
    stopifnot(all(samplingPops %in% 1:nPops))
    stopifnot(all(dim(migProbs) == nPops))
    stopifnot(length(samplingGens) == length(samplingPops))
    stopifnot(length(samplingGens) == length(nSamples))
    invMigProbs <- solve(migProbs)
    gen <- min(samplingGens)
    lastSampling <- max(samplingGens)
    totSamples <- sum(nSamples)
    ninternal <- totSamples - 1
    nnode <- totSamples + ninternal
    nedge <- 2*ninternal
    nodeHeights <- numeric(nnode)
    linPops <- integer(nnode)
    nodePops <- numeric(nnode)
    linIds <- 1:nnode
    edge <- matrix(nrow=nedge, ncol=2)
    edge.length <- numeric(nedge)
    nextNode <- nnode
    nextEdge <- 1
    if(!is.null(sampleLabels)){
        stopifnot(length(sampleLabels) == totSamples)
        stopifnot(nSamples == 1)
        tip.label <- character(totSamples)
    }
    isFuture <- rep(FALSE, length.out=nnode)
    nextSample <- 1
    inds <- which(samplingGens == gen)
    for (ind in inds){
        for (i in 1:nSamples[ind]){
            isFuture[nextSample] <- TRUE
            nodeHeights[nextSample] <- gen
            linPops[nextSample] <- samplingPops[ind]
            nodePops[nextSample] <- samplingPops[ind]
            if(!is.null(sampleLabels)){
                tip.label[nextSample] <- sampleLabels[ind]
            }
            nextSample <- nextSample + 1
        }
    }
    isCurrent <- isFuture
    nlin <- sum(isFuture)
    ltt <- list(lineages=list(nlin), jumpTimes=list(gen))
    Nt <- N
    Ntraj <- list(Nt)
    while(nlin > 1 || gen <= lastSampling){
        Ntt <- Nt %*% invMigProbs
        Ntt[Ntt<1] <- 1
        Nt <- Ntt*sum(Nt)/sum(Ntt)
        if (gen %% 10 == 0) {
            Ntraj <- c(Ntraj, list(as.numeric(Nt)))
        }
        gen <- gen + 1
        curPops <- unique(linPops[isCurrent])
        for (pop in curPops) {
            test <- linPops[isCurrent] == pop
            prob <- Nt * migProbs[, pop]
            size <- sum(test)
            if( is.na(size))  browser()
            if( length(prob) != nPops) browser()
            if( any(prob <=0)) browser()
            ancestorPops <- sample(nPops, size=size, replace=TRUE, prob=prob)
            linPops[isCurrent][test] <- ancestorPops
        }
        curPops <- unique(linPops[isCurrent])
        isCurrent <- isFuture
        for (pop in curPops) {
            testPop <- linPops == pop & isCurrent
            nlinPop <- sum(testPop)
            if(nlinPop > 1) {
                ancestors <- sample(ceiling(Nt[pop]), size=nlinPop, replace=TRUE)
                for(i in 1:(nlinPop - 1)){
                    for(j in (i + 1):nlinPop){
                        if (ancestors[i] == ancestors[j]){
                            nodeHeights[nextNode] <- gen
                            lini <- linIds[testPop][i]
                            linj <- linIds[testPop][j]
                            test <- c(lini, linj) %in% edge[, 2]
                            if (test[1] && !test[2]){
                                ind <- which(edge[,2] == lini)
                                parent <- edge[ind, 1]
                                edge[nextEdge, ] <- c(parent, linj)
                                edge.length[nextEdge] <- nodeHeights[parent] - nodeHeights[linj]
                                nextEdge <- nextEdge + 1
                                isFuture[linj] <- FALSE
                            } else if (!test[1] && test[2]){
                                ind <- which(edge[,2] == linj)
                                parent <- edge[ind, 1]
                                edge[nextEdge, ] <- c(parent, lini)
                                edge.length[nextEdge] <- nodeHeights[parent] - nodeHeights[lini]
                                nextEdge <- nextEdge + 1
                                isFuture[lini] <- FALSE
                            } else if (!any(test)){
                                edge[nextEdge, ] <- c(nextNode, lini)
                                edge.length[nextEdge] <- nodeHeights[nextNode] - nodeHeights[lini]
                                nextEdge <- nextEdge + 1
                                edge[nextEdge, ] <- c(nextNode, linj)
                                edge.length[nextEdge] <- nodeHeights[nextNode] - nodeHeights[linj]
                                nextEdge <- nextEdge + 1
                                isFuture[c(lini, linj)] <- FALSE
                                isFuture[nextNode] <- TRUE
                                nodePops[nextNode] <- pop
                                linPops[nextNode] <- pop
                                nextNode <- nextNode - 1
                            }
                        }
                    }
                }
            }
        }
        if (gen %in% samplingGens){
            inds <- which(samplingGens == gen)
            for (ind in inds){
                for (i in 1:nSamples[ind]){
                    isFuture[nextSample] <- TRUE
                    nodeHeights[nextSample] <- gen
                    linPops[nextSample] <- samplingPops[ind]
                    nodePops[nextSample] <- samplingPops[ind]
                    if(!is.null(sampleLabels)) {
                        tip.label[nextSample] <- sampleLabels[ind]
                    }
                    nextSample <- nextSample + 1
                }
            }
        }
        nlinNext <- sum(isFuture)
        if(nlinNext != nlin) {
            ltt$lineages <- c(ltt$lineages, nlinNext)
            ltt$jumpTimes <- c(ltt$jumpTimes, gen)
            nlin <- nlinNext
        }
    }
    if (nextNode != totSamples) {
        diff <- nextNode - totSamples
        ninternal <- ninternal - diff
        nedge <- nedge - diff
        edge <- edge[1:nedge, ]
        edge[edge > totSamples] <- edge[edge > totSamples] - diff
        edge.length <- edge.length[1:nedge]
        start <- totSamples + diff + 1
        end <- start + ninternal - 1
        nodePops <- c(nodePops[1:totSamples], nodePops[start:end])
    }
    if(is.null(sampleLabels)){
        tip.label <- as.character(1:totSamples)
    }
    res <- list(edge=edge,  Nnode=as.integer(ninternal),
                tip.label=tip.label,
                edge.length=edge.length)
    class(res) <- 'phylo'
    ltt <- lapply(ltt, unlist)
    list(phy=res, ltt=ltt, nodePops=nodePops, nodeHeights=nodeHeights, Ntraj=Ntraj)
}

coalStats <- function(ltt){
    jumps <- diff(ltt$lineages)
    holdingTimes <- diff(ltt$jumpTimes)
    k <- ltt$lineages[-length(ltt$lineages)]
    npairs <- k*(k-1)/2
    ci <- list(); cr <- list()
    i <- 1
    while(i < length(jumps)){
        if(jumps[i] < 0) {
            ci <- c(ci, holdingTimes[i])
            cr <- c(cr, npairs[i])
            i <- i + 1
        } else {
            stopifnot(jumps[i] > 0)
            ht <- holdingTimes[c(i, i + 1)]
            np <- npairs[c(i, i + 1)]
            holdingTimes[i + 1] <- sum(ht)
            npairs[i + 1] <- sum(ht*np/sum(ht))
            i <- i + 1
        }
    }
    list(ci=unlist(ci), cr=unlist(cr))
}

get.ltt.phylo <- function(phy){
    nd <- node.depth.edgelength(phy)
    nd <- max(nd) - nd
    nt <- length(phy$tip.label)
    delta <- as.integer(c(rep(1, nt), 1 - table(phy$edge[,1])))
    jumps <- tapply(delta, nd, sum)
    test <- jumps != 0
    lin <- cumsum(jumps[test])
    ltt <- list()
    ltt$lineages <- unname(lin)
    ltt$jumpTimes <- as.numeric(names(lin))
    ltt
}

ran.gen.tree <- function(data, pars, levnames=levs, genTime=as.numeric(ddays(7)),
                         branchUnits=as.numeric(ddays(365)), unitsToEvenDist=4, N=70){
    K <- length(levnames)
    gensPerUnit <- branchUnits/genTime
    Q <- getRateMatrix(data$dm, pars)
    sampleLabels <- lapply(data$msal, names)
    sampCfgs <- lapply(sampleLabels, getSampleConfig, levs=levnames, genTime=genTime)
    migProbs <- expm(Q/gensPerUnit)
    Ni <- N/K
    Ni <- rep(Ni, K) %*% expm(Q*unitsToEvenDist)
    Ni[Ni < 1] <- 1
    Ni <- Ni * N / sum(Ni)
    tmpf <- function(sampCfg, sampleLab){
        treesim(Ni, nSamples=sampCfg$ns, samplingGens=sampCfg$sg,samplingPops=sampCfg$sp, migProbs=migProbs, sampleLabels=sampleLab)
    }
    p <- mapply(tmpf, sampCfgs, sampleLabels, SIMPLIFY=FALSE)
    res <- lapply(data$tmlol, '[', 1)
    tmpf <- function(x, y) {
        tree <- y$phy
        tree$edge.length <- tree$edge.length / gensPerUnit
        tree <- multi2di(tree)
        x[[1]]$tree <- write.tree(tree)
        x
    }
    res <- mapply(tmpf, x=res, y=p, SIMPLIFY=FALSE)
    data$tmlol <- res
    data
}

get.exp.stats <- function(tree){
}

get.param.stat.tree <- function(data, exponentialityStats=FALSE, altDm) {
    np <- ncol(data$dm)
    pars <- c(-0.5, rep(0, np))
    ans <- optim.rphast(obj, params=pars, lower=rep(-3, np + 1), upper=c(0, rep(5, np)),
                        tmlol=data$tmlol, x=data$dm, msal=data$msal)
    if(ans$par[2] > .95) browser()
    np <- ncol(altDm)
    pars <- c(-0.5, rep(0, np))
    altans <- optim.rphast(obj, params=pars, lower=rep(-3, np + 1), upper=c(0, rep(5, np)),
                           tmlol=data$tmlol, x=altDm, msal=data$msal)
    if(exponentialityStats){
        tmpf <- function(x) read.tree(text=x[[1]]$tree)
        trees <- lapply(data$tmlol, tmpf)
        ltt <- lapply(trees, get.ltt.phylo)
        cs <- lapply(ltt, coalStats)
        tmpf <- function(c){
            y <- c$ci * c$cr
            gini.exp.test(y, simulate=length(y < 30))
        }
        htl <- lapply(cs, tmpf)
        expPvals <- sapply(htl, '[[', 'p.value')
        rej <- expPvals < 0.05
        expStats <- sapply(htl, '[[', 'statistic')
        c(ans$par, altans$par, rej, expStats)
    } else c(ans$par, altans$par)
}

#' ### Parametric bootstrap to study bias from sample variables, exponentiality of trees

bsParamR <- 1e3
modData <- list(tmlol=mods, msal=pedvMSA, dm=dMats[['inship']])
dMats[['inshipSamp']] <- cbind(dMats[['inship']], x[, grep('Samples$', colnames(x))])
system.time(
bsTree <- boot(data=modData, statistic=get.param.stat.tree, R=bsParamR, sim='parametric',
               ran.gen=ran.gen.tree, mle=ans[['inship']]$par, parallel='multicore',
               ncpus=detectCores(), exponentialityStats=TRUE, altDm=dMats[['inshipSamp']])
)

bsTree

#' ## Check for normality, any signs something is wrong with simulations

tmpf <- function(x) plot(bsTree, index=x)
invisible(sapply(seq(ncol(bsTree$t)), tmpf))

tmpf <- function(){
    plotData <- bsTree$t[, c(2, 4:6)]
    colnames(plotData) <- c('Inshipments\nto destination,\nalone', 'Inshipments\nto destination,\nwith sample counts',
                            'Samples\nfrom origin', 'Samples\nfrom destination')
    plotData <- melt(plotData)
    g <- ggplot(data=plotData, aes_string(x='Var2', y='value'))
    g <- g + geom_hline(yintercept=ans[['inship']]$par[2], col='red')
    g <- g + geom_hline(yintercept=0, col='grey')
    g <- g + geom_boxplot()
    g <- g + labs(x='\nVariable', y='Bootstrap effect estimates\n')
    g <- g + theme_classic()
    g
}
ggsave(plot=tmpf(), filename='tree-bootstrap-boxplot.pdf', width=7, height=5, pointsize=12)

#' ## Functions for elastic-net regularization paths

getInit <- function(msal=pedvMSA, tmlol=mods){
    tmpf <- function(x, y){
        dloc <- outer(y$seq, y$seq, '==')
        colnames(dloc) <- names(y)
        rownames(dloc) <- names(y)
        tmpff <- function(xx) {
            phy <- read.tree(text=xx$tree)
            dphy <- cophenetic(phy)
            dphy <- dphy[rownames(dloc), colnames(dloc)]
            rdist <- dloc / dphy
            mean(rdist[upper.tri(rdist)])
        }
        lapply(x, tmpff)
    }
    res <- mapply(tmpf, x=tmlol, y=msal, SIMPLIFY=FALSE)
    tmpf <- function(x) mean(unlist(x))
    res <- sapply(res, tmpf)
    tmpf <- function(x) length(x$seq)
    nseq <- sapply(pedvMSA, tmpf)
    w <- nseq*(nseq - 1)
    res <- weighted.mean(res, w=w)
    log(res)
}

getClusters <- function(tmlol=mods, migsPerTime=1){
    tmpf <- function(x, y){
        tmpff <- function(xx) {
            phy <- read.tree(text=xx$tree)
            cophenetic(phy)
        }
        res <- lapply(x, tmpff)
        res <- Reduce('+', res)/length(res)
        -res
    }
    res <- lapply(tmlol, tmpf)
    joinMats <- function(A, B){
        od <- matrix(-Inf, nrow=nrow(B), ncol=ncol(A))
        rownames(od) <- rownames(B)
        colnames(od) <- colnames(A)
        left <- rbind(A, od)
        od <- matrix(-Inf, nrow=nrow(A), ncol=ncol(B))
        rownames(od) <- rownames(A)
        colnames(od) <- colnames(B)
        right <- rbind(od, B)
        cbind(left, right)
    }
    res <- Reduce(joinMats, res)
    res <- exp(res*migsPerTime)
    d <- as.dist(res)
    hc <- hclust(d, method='complete')
    hc
}

dtlmnet <- function(x, y, alpha=1, nlambda=100, lambda.min.ratio=0.01,
                    lambda=NULL, standardize=TRUE, intercept=TRUE, thresh=1e-4,
                    dfmax=nvars + 1, pmax=min(dfmax*2 + 20,nvars), exclude,
                    penalty.factor=rep(1, nvars), lower.limits=-Inf,
                    upper.limits=Inf, maxit=100){
    # written using glmnet as a template
    if (alpha > 1) {
        warning("alpha >1; set to 1")
        alpha <- 1
    }
    if (alpha < 0) {
        warning("alpha<0; set to 0")
        alpha <- 0
    }
    alpha <- as.double(alpha)
    this.call <- match.call()
    nlam <- as.integer(nlambda)
    np <- dim(x)
    if (is.null(np) | (np[2] < 1))
        stop("x should be a matrix with 1 or more columns")
    nrates <- as.integer(np[1])
    nvars <- as.integer(np[2])
    k <- nchar(y$tmlol[[1]][[1]]$alphabet)
    if (k*(k-1) != nrates)
        stop(paste("number of ordered pairs of states for trait (", k*(k-1), ") not consistent with the number of predicted transition rates (", nrates, ")", sep = ""))
    vnames <- colnames(x)
    if (is.null(vnames))
        vnames <- paste("V", seq(nvars), sep = "")
    ne <- as.integer(dfmax)
    nx <- as.integer(pmax)
    if (!missing(exclude)) {
        jd <- match(exclude, seq(nvars), 0)
        if (!all(jd > 0))
            stop("Some excluded variables out of range")
        jd <- as.integer(c(length(jd), jd))
    }
    else jd <- as.integer(0)
    vp <- as.double(penalty.factor)
    if (any(lower.limits > 0)) {
        stop("Lower limits should be non-positive")
    }
    if (any(upper.limits < 0)) {
        stop("Upper limits should be non-negative")
    }
    if (length(lower.limits) < nvars) {
        if (length(lower.limits) == 1)
            lower.limits <- rep(lower.limits, nvars)
        else stop("Require length 1 or nvars lower.limits")
    }
    else lower.limits <- lower.limits[seq(nvars)]
    if (length(upper.limits) < nvars) {
        if (length(upper.limits) == 1)
            upper.limits = rep(upper.limits, nvars)
        else stop("Require length 1 or nvars upper.limits")
    }
    else upper.limits <- upper.limits[seq(nvars)]
    cl = rbind(lower.limits, upper.limits)
    if (any(abs(cl) < thresh)) {
        stop("Cannot enforce limits this close to zero")
    }
    storage.mode(cl) <- "double"
    isd <- as.integer(standardize)
    intr <- as.integer(intercept)
    thresh <- as.double(thresh)
    if (is.null(lambda)) {
        if (lambda.min.ratio >= 1)
            stop("lambda.min.ratio should be less than 1")
        flmin <- as.double(lambda.min.ratio)
        ulam <- double(1)
    }
    else {
        flmin <- as.double(1)
        if (any(lambda < 0))
            stop("lambdas should be non-negative")
        ulam <- as.double(rev(sort(lambda)))
        nlam <- as.integer(length(lambda))
    }
    fit <- dtnet(x, y, alpha, nobs, nvars, jd, vp, cl, ne, nx, nlam, flmin,
                 ulam, thresh, isd, intr, vnames, maxit)
    fit$call <- this.call
    fit$nrates <- nrates
    class(fit) <- c(class(fit), "dtlmnet")
    fit
}

dtnet <- function(x, y, alpha, nobs, nvars, jd, vp, cl, ne, nx, nlam, flmin,
                  ulam, thresh, isd, intr, vnames, maxit, a=0.1, r=0.01,
                  relStart=0.1, mubar=1, beta=0.9, verbose=FALSE, debug=TRUE,
                  initFactor=10){
    maxit <- as.integer(maxit)
    niter <- 0
    if(!intr) stop("not implemented")
    dim <- nvars + intr
    parInds <- seq(dim)
    I <- diag(nrow=dim)
    nll <- function(w){
        -obj2(w=w, x=x, y=y)
    }
    scaleEst <- getInit(msal=y$msal, tmlol=y$tmlol)
    par <- c(scaleEst, rep(0, nvars))
    gnll <- grad(nll, x=par, method='simple')
    mu <- mubar
    stopifnot(beta>0, beta<1)
    G <- diag(initFactor * abs(gnll), ncol=dim)
    if(flmin<1){
        lstart <- max(abs(gnll))
        loglstart <- log10(lstart) + relStart
        log10LambdaRange <- -log10(flmin)
        loglend <- loglstart - log10LambdaRange
        logstep <- (loglend - loglstart)/nlam
        lambda <- loglstart + 0:(nlam - 1)*logstep
        lambda <- 10^lambda
    } else {
        lambda <- ulam
    }
    res <- list()
    fsg <- function(p, g, l1, l2, h) {
        if(p==0) {
            max(abs(g) - l1, 0)
        } else if (p > 0){
            (-g - l1 - l2*p)/(h + l2)
        } else {
            (-g + l1 - l2*p)/(h + l2)
        }
    }
    for (i in seq_along(lambda)){
        l1penalty <- lambda[i] * c(0, vp) * alpha
        l2penalty <- lambda[i] * c(0, vp) * (1 - alpha)
        penFunc <- function(par) abs(par) %*% l1penalty + (par^2 %*% l2penalty)/2
        k <- 0
        nlp <- nll(par)
        F1 <- nlp + penFunc(par)
        H <- I/(2*mu) + G
        sg <- mapply(fsg, p=par, g=gnll, l1=l1penalty, l2=l2penalty, h=diag(H))
        nsg <- max(abs(sg))
        while (nsg > thresh && k < maxit){
            H <- I/(2*mu) + G
            d <- numeric(dim)
            dlist <- list()
            fmlist <- list()
            inactive <- par != 0 | sg != 0 ## inactive means not actively fixed to zero in solution
            nInactive <- sum(inactive)
            ndesc <- (1 + floor(k * a)) * nInactive
            for (nd in 1:ndesc){
                j <- sample.int(n=nInactive, size=1)
                j <- parInds[inactive][j]
                Hd <- H %*% d
                gr <- gnll[j] + Hd[j]
                if (par[j] + d[j] > 0 || (par[j] + d[j] == 0 & -gr > 0)){
                    z <- (-gr - l1penalty[j] - l2penalty[j]*(par[j] + d[j]))/(H[j,j] + l2penalty[j])
                    if (par[j] + d[j] + z < 0){
                        d[j] <- -par[j]
                    } else {
                        d[j] <- d[j] + z
                    }
                } else {
                    z <- (-gr + l1penalty[j] - l2penalty[j]*(par[j] + d[j]))/(H[j,j] + l2penalty[j])
                    if (par[j] + d[j] + z > 0){
                        d[j] <- -par[j]
                    } else {
                        d[j] <- d[j] + z
                    }
                }
                dlist[[nd]] <- d
                fmlist[[nd]] <- d %*% (H/2) %*% d + gnll %*% d + F1 - penFunc(par) + penFunc(par + d)
            }
            if(any(diff(c(F1, unlist(fmlist)))>1e-10)) browser()
            par2 <- par + d
            if (any(par2[-1] > cl[2, ] || any(par2[-1] < cl[1, ]))){
                if(verbose) cat('backtracking: out of bounds', '\n')
                mu <- mu * beta
            } else {
                Fmod <- d %*% (H/2) %*% d + gnll %*% d + F1 - penFunc(par) + penFunc(par2)
                if(Fmod  > F1 && !isTRUE(all.equal(Fmod, F1))) {
                    if (debug) browser()
                    if(verbose) cat('backtracking: poorly solved model', '\n')
                    mu <- mu * beta
                } else {
                    nlp <- nll(par2)
                    F2 <- nlp + penFunc(par2)
                    if (F2 - F1 > r * (Fmod - F1)){
                        if(verbose) cat('backtracking: insufficient decrease', '\n')
                        mu <- mu * beta
                    } else {
                        gnll2 <- grad(nll, x=par2, method='simple')
                        yvec <- gnll2 - gnll
                        s <- d
                        ys <- yvec %*% s
                        if (ys > 0){
                            ## Hessian approximation update via BFGS via 8.19 in Nocedal and Wright
                            sColVec <- matrix(s, ncol=1)
                            yColVec <- matrix(yvec, ncol=1)
                            M <- G %*% sColVec %*% t(sColVec) %*% G
                            M <- M / as.numeric(t(sColVec) %*% G %*% sColVec)
                            M <- G - M
                            G <- M + yColVec %*% t(yColVec) / as.numeric(t(yColVec) %*% sColVec)
                            if (any(diag(G) <= 0)) browser()
                        } else if(verbose){
                            cat('skipping Hessian update: ys <= 0', '\n')
                        }
                        ## update vars
                        k <- k + 1
                        par <- par2
                        gnll <- gnll2
                        dF <- F2 - F1
                        F1 <- F2
                        H <- I/(2*mu) + G
                        sg <- mapply(fsg, p=par, g=gnll, l1=l1penalty, l2=l2penalty, h=diag(H))
                        nsg <- max(abs(sg))
                        if (debug && mu < 1e-8 && nsg > thresh) browser()
                        if (verbose) {
                            cat('lambda: ', lambda[i], '\n')
                            cat('k: ', k, '\n')
                            cat('F: ', as.numeric(F1), '\n')
                            cat('par: ', signif(par, 3), '\n')
                            cat('grad: ', signif(gnll, 3), '\n')
                            cat('nsg: ', signif(nsg, 3), '\n')
                            cat('\n')
                        }
                    }
                }
            }
        }
        convergence <- ifelse(k == maxit, 'no', 'yes')
        res[[i]] <- list(par=par, nll=nlp, k=k, lambda=lambda[i], convergence=convergence, mu=mu, nsg=nsg, sg=sg)
        mu <- mubar
    }
    path <- sapply(res, '[[', 'par')
    ret <- list(a0=path[1,])
    beta <- path[-1, ]
    colnames(beta) <- paste("s", seq(ncol(beta)) - 1, sep = "")
    rownames(beta) <- vnames
    ret$beta <- beta
    ret$lambda <- sapply(res, '[[', 'lambda')
    ret$nll <- sapply(res, '[[', 'nll')
    ret$df <- colSums(abs(beta) > 0)
    ret$dim <- dim(x)
    ret$niterations <- sum(sapply(res, '[[', 'k'))
    ret$jerr <- paste('convergence: ', sapply(res, '[[', 'convergence'))
    if(verbose) cat('Completed regularization path', '\n')
    ret
}

plotCoef <- function (beta, norm, lambda, df, dev, label = FALSE, xvar = c("norm",
    "lambda", "dev"), xlab = iname, ylab = "Coefficients", ...) {
    which <- which(rowSums(abs(beta)) > 0)
    nwhich <- length(which)
    switch(nwhich + 1, `0` = {
        warning("No plot produced since all coefficients zero")
        return()
    }, `1` = warning("1 or less nonzero coefficients; glmnet plot is not meaningful"))
    beta = as.matrix(beta[which, , drop = FALSE])
    xvar = match.arg(xvar)
    switch(xvar, norm = {
        index = if (missing(norm)) apply(abs(beta), 2, sum) else norm
        iname = "L1 Norm"
        approx.f = 1
    }, lambda = {
        index = log(lambda)
        iname = "Log Lambda"
        approx.f = 0
    }, dev = {
        index = dev
        iname = "Fraction Deviance Explained"
        approx.f = 1
    })
    dotlist = list(...)
    type = dotlist$type
    if (is.null(type))
        matplot(index, t(beta), lty = 1, xlab = xlab, ylab = ylab,
            type = "l", ...)
    else matplot(index, t(beta), lty = 1, xlab = xlab, ylab = ylab,
        ...)
    atdf = pretty(index)
    prettydf = approx(x = index, y = df, xout = atdf, rule = 2,
        method = "constant", f = approx.f)$y
    axis(3, at = atdf, labels = prettydf, tcl = NA)
    if (label) {
        nnz = length(which)
        xpos = max(index)
        pos = 4
        if (xvar == "lambda") {
            xpos = min(index)
            pos = 2
        }
        xpos = rep(xpos, nnz)
        ypos = beta[, ncol(beta)]
        text(xpos, ypos, paste(which), cex = 0.5, pos = pos)
    }
}

plot.dtlmnet <- function (x, xvar = c("norm", "lambda", "dev"),
                          label = FALSE, ...){
    xvar = match.arg(xvar)
    plotCoef(x$beta, lambda = x$lambda, df = x$df, dev = x$dev.ratio,
             label = label, xvar = xvar, ...)
}

print.dtlmnet <- function(x, digits = max(3, getOption("digits") - 3), ...){
    cat("\nCall: ", deparse(x$call), "\n\n")
    print(cbind(Df = x$df, `ll` = signif(-x$nll, digits),
        Lambda = signif(x$lambda, digits)))
}

y <- list(tmlol=mods, msal=pedvMSA)
samplingInds <- grep("Samples$", colnames(x))
inshipInds <- grep("Inshipments$", colnames(x))
system.time(dfit <- dtlmnet(x=x[, -samplingInds], y=y, nlambda=100, alpha=0.8))
plot(dfit, xvar='n', label=T)

#' ## Stability selection

filterTips <- function(tmlol, keepers){
    prune <- function(xx){
        tr <- xx$tree
        tr <- prune.tree(tr, keepers, all.but=TRUE)
        xx$tree <- tr
        xx
    }
    tmpf <- function(x) {
        lapply(x, prune)
    }
    lapply(tmlol, tmpf)
}

filterSeqs <- function(msal, keepers){
    tmpf <- function(x){
        test <- x$names %in% keepers
        x[test, ]
    }
    lapply(msal, tmpf)
}

dtlmnet.subset <- function (index, subsets, x, y, lambda, weakness, p, ...){
    nms <- subsets[[index]]
    tmlol <- filterTips(y$tmlol, nms)
    msal <- filterSeqs(y$msal, nms)
    ysub <- list(tmlol=tmlol, msal=msal)
    dtlmnet(x, ysub, lambda = lambda, penalty.factor = 1/runif(p, weakness, 1), ...)$beta != 0
}

stabpathDtnet <- function (y, x, size = 0.632, steps = 100, weakness = 1,
                           mc.cores = getOption("mc.cores", 2L), ...){
    ## written using c060::stabpath as template
    fit <- dtlmnet(x, y, ...)
    p <- ncol(x)
    tipnames <- sapply(y$msal, names)
    tmpf <- function(tn){
        sample(tn, ceiling(length(tn) * size))
    }
    tmpff <- function(){
        unlist(sapply(tipnames, tmpf))
    }
    subsets <- replicate(steps, tmpff(), simplify=FALSE)
    if (.Platform$OS.type != "windows") {
        res <- mclapply(1:steps, mc.cores = mc.cores, dtlmnet.subset,
            subsets, x, y, lambda = fit$lambda, weakness, p,
            ...)
    }
    else {
        cl <- makePSOCKcluster(mc.cores)
        clusterExport(cl, c("glmnet", "drop0"))
        res <- parLapply(cl, 1:steps, dtlmnet.subset, subsets,
            x, y, lambda = fit$lambda, weakness, p, ...)
        stopCluster(cl)
    }
    res <- res[unlist(lapply(lapply(res, dim), function(x) x[2] ==
        dim(res[[1]])[2]))]
    x <- as.matrix(res[[1]])
    qmat <- matrix(ncol = ncol(res[[1]]), nrow = length(res))
    qmat[1, ] <- colSums(as.matrix(res[[1]]))
    for (i in 2:length(res)) {
        qmat[i, ] <- colSums(as.matrix(res[[i]]))
        x <- x + as.matrix(res[[i]])
    }
    x <- x/length(res)
    qs <- colMeans(qmat)
    out <- list(fit = fit, x = x, qs = qs)
    class(out) <- "stabpath"
    return(out)
}

system.time(sp <- stabpathDtnet(x=x[, -samplingInds], y=y, steps=20, nlambda=10,
                                lambda.min.ratio=0.05, alpha=0.8))
plot(sp, type='pfer', error=1, xvar='l')
plot(sp, type='pcer', error=0.05, xvar='l')

pdf('stability-path.pdf')
plot(sp, type='pcer', error=0.05, xvar='l')
dev.off()

save.image('mle.RData')


# Information about code:
# This code corresponds to exploratory data analyses for my MSc thesis.
# They are pertaining to EDA for the authors (relevant for Chapter 1).
# @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@

# Set up
source('2019-06-19-jsa-type/subset.r')

# Parameters
theme <- theme_minimal()

# TODO:
# Where are most of the describers?
# How many species in author lifetime? How many species per year?
# How many authors per species over time?
# What are the trends in species distribution (N number of species in publications)?
# What is the description rate across countries?
# Where are the specimens/ repositories/ publishers?

# How many type repository in each genus?

# Calculate effort it takes to describe all species?

# @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
# Section - basic summary statistics for taxonomist analysis
# @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
print(paste0(Sys.time(), " --- basic summary statistics for species dataset"))

df <- get_df1(write=F)
authors <- df[, c("full.name.of.describer", "idx")] %>%
    separate_rows(full.name.of.describer, sep="; ")
authors <- data.table(authors)[, .N, by="idx"]
ggplot(authors, aes(x=N)) + geom_histogram(binwidth=1) +
    labs(x="\nN authors", y="Frequency\n") + theme
table(authors$N)
prop.table(table(authors$N))

print(paste0(Sys.time(), " --- basic summary statistics for taxonomist dataset"))

df_describers <- get_des(write=F)
df_describers <- df_describers[full.name.of.describer.n != "Silas Bossert"]

# How long are taxonomists active for?
ggplot(df_describers, aes(years_active)) +
    geom_histogram(binwidth=1) +
        theme_minimal()
summary(df_describers$years_active)
# Median = 3
# Min = 1, Max = 83

# How many species are described?
ggplot(df_describers, aes(num_species_described)) +
    geom_histogram(binwidth=100) +
        theme_minimal()
summary(df_describers$num_species_described)
# Median = 4
# Min = 1, Max = 3136 (by a far margin)

# Who were the greatest taxonomists? Are the greatest taxonomists still alive? None are alive sadly
df_describers[order(-num_species_described)][1:10][,c("full.name.of.describer.n", "dod.describer.n")]
df_describers[order(-num_first_auth_species_described
)][1:10][,c("full.name.of.describer.n", "dod.describer.n")]

# Hist of number of describers per species
ggplot(df_species_describers_sum, aes(N_authors)) +
    geom_histogram(binwidth=1)
table(df_species_describers_sum$N_authors)

# Were the greatest taxonomists always first authors?
## Last authors
cor(df_describers$num_species_described, df_describers$prop_species_described_as_last_author)^2
cor(df_describers[num_species_described<500]$num_species_described,
    df_describers[num_species_described<500]$prop_species_described_as_last_author)^2

ggplot(df_describers[num_species_described<500], aes(num_species_described, prop_species_described_as_last_author)) +
    geom_point() + theme_minimal()
ggplot(df_describers, aes(num_species_described, prop_species_described_as_last_author)) +
    geom_point() + theme_minimal()

## Not as first authors
cor(df_describers$num_species_described, df_describers$prop_species_described_not_as_first_author)^2
cor(df_describers[num_species_described<500]$num_species_described,
    df_describers[num_species_described<500]$prop_species_described_not_as_first_author)^2

ggplot(df_describers[num_species_described<500],
       aes(num_species_described, prop_species_described_not_as_first_author)) +
    geom_point() + theme_minimal()
ggplot(df_describers, aes(num_species_described, prop_species_described_not_as_first_author)) +
    geom_point() + theme_minimal()
# Does not appear to be a correlation when a continuous variable

# But probably there are some who are always last authors for all
df_describers[order(-prop_species_described_as_last_author)][
    ,c("full.name.of.describer.n", "prop_species_described_as_last_author")]

# Also as seen here
# Hist of prop_species_described_as_last_author
ggplot(df_describers, aes(prop_species_described_as_last_author)) +
    geom_histogram(binwidth=0.1) + theme_minimal()
# INTERESTING. The second peak

ggplot(df_describers, aes(prop_species_described_not_as_first_author)) +
    geom_histogram(binwidth=0.1) + theme_minimal()
# Similar to the previous plot

# when were these people alive
summary(as.numeric(df_describers[prop_species_described_as_last_author<0.9]$dob.describer.n))
summary(as.numeric(df_describers[prop_species_described_as_last_author>=.9]$dob.describer.n))
# Not very reliable due to missing data

# when were these people active
summary(as.numeric(df_describers[prop_species_described_as_last_author<0.9]$max))
summary(as.numeric(df_describers[prop_species_described_as_last_author>=.9]$max))
# Seem that those with higher proportion of species described as last author are more recent

# Where are most of the taxonomists
des_a <- df_describers[spp_N_1st_auth_s>=1]

des_a1 <- df_describers[, c("full.name.of.describer.n", "residence.country.describer.full")] %>%
    separate_rows(residence.country.describer.full, sep= "; ")
des_a1 <- des_a1[, .N, by="full.name.of.describer.n"]
table(des_a1$N)
prop.table(table(des_a1$N))

# Write datasets
dataset_write = merge(des_a1[N>=2],
                      df_describers[, c("full.name.of.describer.n",
                                        "residence.country.describer.full"),
                      by="full.name.of.describer.n", all.x=T, all.y=F]

filename_write = paste0(dir_data_ch1, "others/2019-10-28-taxonomist-country-res-morethanone.csv")
write.csv(dataset_write, filename_write)

filename_write = paste0(dir_data_ch1, "others/2019-10-28-taxonomist-country-res-summary.csv")
write.csv(df_describers[, .N,by=c("residence.country.describer.first")][order(-N)],
          filename_write)


#' S3 plotting method for diffnet objects.
#'
#' @param x An object of class \code{\link[=diffnet-class]{diffnet}}
#' @param t Integer scalar indicating the time slice to plot.
#' @param vertex.color Character scalar/vector. Color of the vertices.
#' @template plotting_template
#' @param main Character. A title template to be passed to sprintf.
#' @param ... Further arguments passed to \code{\link[igraph:plot.igraph]{plot.igraph}}.
#' @param y Ignored.
#' @export
#'
#' @family diffnet methods
#'
#' @return A matrix with the coordinates of the vertices.
#' @author George G. Vega Yon
#' @examples
#'
#' data(medInnovationsDiffNet)
#' plot(medInnovationsDiffNet)
#'
#'
plot.diffnet <- function(
  x,y=NULL, t=1,
  vertex.color  = c(adopt="steelblue", noadopt="white"),
  vertex.size = "degree",
  main        = "Diffusion network in time %d",
  minmax.relative.size = getOption("diffnet.minmax.relative.size", c(0.01, 0.04)),
  ...) {

  # Listing arguments
  igraph.args <- list(...)

  # Checking that the time period is actually within
  if (!(t %in% 1:x$meta$nper))
    stop("-t- must be an integer within 1 and ",x$meta$nper,".")

  # Extracting the graph to be plotted
  graph <- diffnet_to_igraph(x)[[t]]

  # Setting the colors
  cols <- with(x, ifelse(cumadopt[,t], vertex.color[1], vertex.color[2]))

  set_igraph_plotting_defaults("igraph.args")

  if (!length(igraph.args$layout))
    igraph.args$layout <- igraph::layout_nicely(graph)

  igraph.args$vertex.color  <- cols

  graphics::plot.new()
  graphics::plot.window(
    xlim = c(-1,1),
    ylim = c(-1,1)
    )

  igraph.args$vertex.size <-
    rescale_vertex_igraph(
      compute_vertex_size(x$graph[[t]], vertex.size),
      minmax.relative.size = minmax.relative.size
      )

  do.call(igraph::plot.igraph, c(
    list(
      x           = graph
    ), igraph.args))

  if (length(main))
    graphics::title(main = sprintf(main, x$meta$pers[t]))

  invisible(igraph.args$layout)
}

#' @export
#' @rdname diffnet-class
print.diffnet <- function(x, ...) {
  with(x, {
    # Getting attrs
    vsa <- paste0(colnames(vertex.static.attrs), collapse=", ")
    if (nchar(vsa) > 50) vsa <- paste0(strtrim(vsa, 50),"...")
    else if (!nchar(vsa)) vsa <- '-'
    nsa <-ncol(vertex.static.attrs)
    if (nsa) vsa <- paste0(vsa," (",nsa, ")")

    vda <- paste0(colnames(vertex.dyn.attrs[[1]]), collapse=", ")
    if (nchar(vda) > 50) vda <- paste0(strtrim(vda, 50),"...")
    else if (!nchar(vda)) vda <- '-'
    nda <- ncol(vertex.dyn.attrs[[1]])
    if (nda) vda <- paste0(vda," (",nda, ")")

    # Getting nodes labels
    nodesl <- paste0(meta$n," (",
                     paste(head(meta$ids, 8), collapse=", "),
                     ifelse(meta$n>8, ", ...", "") ,")")

    cat(
    "Dynamic network of class -diffnet-",
    paste(" Name               :", meta$name),
    paste(" Behavior           :", meta$behavior),
    paste(" # of nodes         :", nodesl ),
    paste(" # of time periods  :", meta$nper, sprintf("(%d - %d)", meta$pers[1], meta$pers[meta$nper])),
    paste(" Type               :", ifelse(meta$undirected, "undirected", "directed")),
    paste(" Final prevalence   :",
          formatC(sum(cumadopt[,meta$nper])/meta$n, digits = 2, format="f")
          ),
    paste(" Static attributes  :", vsa),
    paste(" Dynamic attributes :", vda),
    sep="\n"
    )
  })
  invisible(x)
}

#' Summary of diffnet objects
#'
#' @export
#' @param object An object of class \code{\link[=as_diffnet]{diffnet}}.
#' @param slices Either an integer or character vector. While integer vectors are used as
#' indexes, character vectors are used jointly with the time period labels.
#' @param valued Logical scalar. When \code{TRUE} weights will be considered.
#' Otherwise non-zero values will be replaced by ones.
#' @param no.print Logical scalar. When TRUE suppress screen messages.
#' @param skip.moran Logical scalar. When TRUE Moran's I is not reported (see details).
#' @param ... Further arguments to be passed to \code{\link{approx_geodesic}}.
#' @details
#' Moran's I is calculated over the
#' cumulative adoption matrix using as weighting matrix the inverse of the geodesic
#' distance matrix. All this via \code{\link{moran}}. For each time period \code{t},
#' this is calculated as:
#'
#' \preformatted{
#'  m = moran(C[,t], G^(-1))
#' }
#'
#' Where \code{C[,t]} is the t-th column of the cumulative adoption matrix,
#' \code{G^(-1)} is the element-wise inverse of the geodesic matrix at time \code{t},
#' and \code{moran} is \pkg{netdiffuseR}'s moran's I routine. When \code{skip.moran=TRUE}
#' Moran's I is not reported. This can be useful for both: reducing computing
#' time and saving memory as geodesic distance matrix can become large. Since
#' version \code{1.18.0}, geodesic matrices are approximated using \code{approx_geodesic}
#' which, as a difference from \code{\link[sna:geodist]{geodist}} from the
#' \pkg{sna} package, and \code{\link[igraph:distances]{distances}} from the
#' \pkg{igraph} package returns a matrix of class \code{dgCMatrix} (more
#' details in \code{\link{approx_geodesic}}).
#'
#' @return A data frame with the following columns:
#' \item{adopt}{Integer. Number of adopters at each time point.}
#' \item{cum_adopt}{Integer. Number of cumulative adopters at each time point.}
#' \item{cum_adopt_pcent}{Numeric. Proportion of comulative adopters at each time point.}
#' \item{hazard}{Numeric. Hazard rate at each time point.}
#' \item{density}{Numeric. Density of the network at each time point.}
#' \item{moran_obs}{Numeric. Observed Moran's I.}
#' \item{moran_exp}{Numeric. Expected Moran's I.}
#' \item{moran_sd}{Numeric. Standard error of Moran's I under the null.}
#' \item{moran_pval}{Numeric. P-value for the observed Moran's I.}
#' @author George G. Vega Yon
#'
#' @examples
#' data(medInnovationsDiffNet)
#' summary(medInnovationsDiffNet)
#'
#' @family diffnet methods
#'
summary.diffnet <- function(
  object,
  slices     = NULL,
  no.print   = FALSE,
  skip.moran = FALSE,
  valued     = getOption("diffnet.valued",FALSE),
  ...) {
  # Subsetting
  if (!length(slices)) slices <- 1:object$meta$nper

  # If no valued
  if (!valued)
    for (i in 1:object$meta$nper)
      object$graph[[i]]@x <- rep(1, length(object$graph[[i]]@x))

  # Checking that the time period is actually within
  test <- !(slices %in% 1:object$meta$nper)
  if (any(test))
    stop("-slices- must be an integer range within 1 and ",object$meta$nper,".")

  slices <- sort(slices)

  # To make notation nicer
  meta <- object$meta

  # Computing density
  d <- unlist(lapply(object$graph[slices], function(x) {
    nlinks(x)/nnodes(x)/(nnodes(x)-1)
    # nelements <- length(x@x)
    # x <-nelements/(meta$n * (meta$n-1))
  }))

  # Computing moran's I
  if (!skip.moran) {

    m <- matrix(NA, nrow=length(slices), ncol=4,
                dimnames = list(NULL, c("moran_obs", "moran_exp", "moran_sd", "moran_pval")))

    for (i in 1:length(slices)) {
      # Computing distances
      g <- approx_geodesic(object$graph[[slices[i]]], ...)

      # Inverting it (only the diagonal may have 0)
      g@x <- 1/g@x

      m[i,] <- unlist(moran(object$cumadopt[,slices[i]], g))
    }
  }
  # Computing adopters, cumadopt and hazard rate
  ad <- colSums(object$adopt[,slices,drop=FALSE])
  ca <- t(cumulative_adopt_count(object$cumadopt))[slices,-3, drop=FALSE]
  hr <- t(hazard_rate(object$cumadopt, no.plot = TRUE))[slices,,drop=FALSE]

  # Left censoring
  lc <- sum(object$toa == meta$pers[1], na.rm = TRUE)
  rc <- sum(is.na(object$toa), na.rm=TRUE)

  out <- data.frame(
    adopt = ad,
    cum_adopt = ca[,1],
    cum_adopt_pcent = ca[,2],
    hazard = hr,
    density=d
  )

  if (!skip.moran) {
    out <- cbind(out, m)
  }

  if (no.print) return(out)

  # Function to print data.frames differently
  header <- c(" Period "," Adopters "," Cum Adopt. (%) ",
              " Hazard Rate "," Density ",
              if (!skip.moran) c(" Moran's I (sd) ") else NULL
              )

  slen   <- nchar(header)
  hline  <- paste(sapply(sapply(slen, rep.int, x="-"), paste0, collapse=""),
                  collapse=" ")
  rule   <- paste0(rep("-", sum(slen) + length(slen) - 1), collapse="")

  # Quick Formatting function
  qf <- function(x, digits=2) sprintf(paste0("%.",digits,"f"), x)

  cat("Diffusion network summary statistics\n",
      "Name     : ", meta$name, "\n",
      "Behavior : ", meta$behavior, "\n",
      rule,"\n",sep="")
  cat(header,"\n")
  cat(hline, "\n")
  for (i in 1:nrow(out)) {
    cat(sprintf(
      paste0("%",slen,"s", collapse=" "),
      qf(meta$pers[slices[i]],0), qf(out[i,1],0),
      sprintf("%s (%s)",
        qf(out$cum_adopt[i],0),
        qf(out$cum_adopt_pcent[i])
        ),
      ifelse(i==1, "-",qf(out$hazard[i])), qf(out$density[i]),
      if (!skip.moran) {
        if (is.nan(out$moran_sd[i]))
          " - "
        else
          sprintf("%s (%s) %-3s",
                  qf(out$moran_obs[i]),
                  qf(out$moran_sd[i]),
                  ifelse(out$moran_pval[i] <= .01, "***",
                         ifelse(out$moran_pval[i] <= .05, "**",
                                ifelse(out$moran_pval[i] <= .10, "*", ""
                              )))
                )
      } else ""
    ), "\n")
  }

  # print(out, digits=2)

  cat(
    rule,
    paste(" Left censoring  :", sprintf("%3.2f (%d)", lc/meta$n, lc)),
    paste(" Right centoring :", sprintf("%3.2f (%d)", rc/meta$n, rc)),
    paste(" # of nodes      :", sprintf("%d",meta$n)),
    "\n Moran's I was computed on contemporaneous autocorrelation using 1/geodesic",
    " values. Significane levels  *** <= .01, ** <= .05, * <= .1.",
    sep="\n"
  )

  invisible(out)
}

#' Plot the diffusion process
#'
#' Creates a colored network plot showing the structure of the graph through time
#' (one network plot for each time period)  and the set of adopter and non-adopters
#' in the network.
#'
#' @templateVar dynamic TRUE
#' @template graph_template
#' @param cumadopt \eqn{n\times T}{n*T} matrix.
#' @param slices Integer vector. Indicates what slices to plot. By default all are plotted.
#' @param vertex.color A character vector of size 3 with colors names.
#' @param vertex.shape A character vector of size 3 with shape names.
#' @template plotting_template
#' @param mfrow.par Vector of size 2 with number of rows and columns to be passed to \code{\link{par}.}
#' @param main Character scalar. A title template to be passed to \code{\link{sprintf}.}
#' @param ... Further arguments to be passed to \code{\link[igraph:plot.igraph]{plot.igraph}}.
#' @param legend.args List of arguments to be passed to \code{\link{legend}}.
#' @param background Either a function to be called before plotting each slice, a color
#' to specify the backgroupd color, or \code{NULL} (in which case nothing is done).
#'
#' @details Plotting is done via the function \code{\link[igraph:plot.igraph]{plot.igraph}}.
#'
#' In order to center the attention on the diffusion process itself, the
#' positions of each vertex are computed only once by aggregating the networks
#' through time, this is, instead of computing the layout for each time \eqn{t},
#' the function creates a new graph accumulating links through time.
#'
#' The \code{mfrow.par} sets how to arrange the plots on the device. If \eqn{T=5}
#' and \code{mfrow.par=c(2,3)}, the first three networks will be in the top
#' of the device and the last two in the bottom.
#'
#' The argument \code{vertex.color} contains the colors of non-adopters, new-adopters,
#' and adopters respectively. The new adopters (default color \code{"tomato"}) have a different
#' color that the adopters when the graph is at their time of adoption, hence,
#' when the graph been plotted is in \eqn{t=2} and \eqn{toa=2} the vertex will
#' be plotted in red.
#'
#' \code{legend.args} has the following default parameter:
#' \tabular{ll}{
#'   \code{x} \tab \code{"bottom"} \cr
#'   \code{legend} \tab \code{c("Non adopters", "New adopters","Adopters")} \cr
#'   \code{pch} \tab \code{sapply(vertex.shape, switch, circle = 21, square = 22, 21)} \cr
#'   \code{bty} \tab \code{"n"} \cr
#'   \code{horiz} \tab \code{TRUE} \cr
#' }
#'
#'
#' @examples
#' # Generating a random graph
#' set.seed(1234)
#' n <- 6
#' nper <- 5
#' graph <- rgraph_er(n,nper, p=.3, undirected = FALSE)
#' toa <- sample(2000:(2000+nper-1), n, TRUE)
#' adopt <- toa_mat(toa)
#'
#' plot_diffnet(graph, adopt$cumadopt)
#' @return Calculated coordinates for the grouped graph (invisible).
#' @family visualizations
#' @keywords hplot
#' @export
#' @author George G. Vega Yon
plot_diffnet <- function(...) UseMethod("plot_diffnet")

#' @export
#' @rdname plot_diffnet
plot_diffnet.diffnet <- function(
  graph, ...
) {

  args <- list(...)

  do.call(
    plot_diffnet.default,
    c(
      list(graph = as_dgCMatrix(graph), cumadopt = graph$cumadopt),
      args
    )
  )

}

#' @rdname plot_diffnet
#' @export
plot_diffnet.default <- function(
  graph, cumadopt,
  slices       = NULL,
  vertex.color = c("white", "tomato", "steelblue"),
  vertex.shape = c("square", "circle", "circle"),
  vertex.size  = "degree",
  mfrow.par    = NULL,
  main         = c("Network in period %s", "Diffusion Network"),
  legend.args  = list(),
  minmax.relative.size = getOption("diffnet.minmax.relative.size", c(0.01, 0.04)),
  background   = NULL,
  ...) {

  set_plotting_defaults("background")

  # Setting parameters
  oldpar <- graphics::par(no.readonly = TRUE)
  on.exit(graphics::par(oldpar))

  # Setting legend parameters, if specified
  if (length(legend.args) | (!length(legend.args) & is.list(legend.args))) {
    if (!length(legend.args$x)) legend.args$x <- "bottom"
    if (!length(legend.args$legend))
      legend.args$legend <-c("Non adopters", "New adopters","Adopters")
    if (!length(legend.args$pch)) {
      legend.args$pch <- sapply(vertex.shape, switch, circle = 21, square = 22, 21)
    }
    if (!length(legend.args$bty)) legend.args$bty <- "n"
    if (!length(legend.args$horiz)) legend.args$horiz <-TRUE
  }

  igraph.args <- list(...)

  # Coercing into a dgCMatrix list
  graph <- as_dgCMatrix(graph)

  if (!is.list(graph))
    stopifnot_graph(graph)

  # Making sure it has names
  add_dimnames.list(graph)
  colnames(cumadopt) <- names(graph)

  # Checking parameters
  t <- nslices(graph)
  n <- nrow(graph[[1]])

  # Checking slices
  if (!length(slices)) {
    slices <- names(graph)[unique(floor(seq(1, t, length.out = min(t, 4))))]
  } else if (is.numeric(slices)) {
    slices <- names(graph)[slices]
  }

  t <- length(slices)

  # Figuring out the dimension
  if (!length(mfrow.par)) {
    if (t<4) mfrow.par <- c(1,t)
    else if (t==4) mfrow.par <- c(2,2)
    else if (t==5) mfrow.par <- c(2,3)
    else if (t==6) mfrow.par <- c(2,3)
    else if (t==7) mfrow.par <- c(2,4)
    else if (t==8) mfrow.par <- c(2,4)
    else if (t==9) mfrow.par <- c(3,4)
    else if (t==10) mfrow.par <- c(3,4)
    else if (t==11) mfrow.par <- c(3,4)
    else if (t==12) mfrow.par <- c(3,4)
    else mfrow.par <- c(ceiling(t/4),4)
  }

  # Computing legend and main width/height
  legend_height_i <- 0
  if (length(legend.args) && length(legend.args$legend)) {
    legend_height_i <- max(sapply(
      legend.args$legend,
      graphics::strheight,
      units="inches",
      cex = if (length(legend.args$cex)) legend.args$cex else NULL
      ))*2.5
  }

  main_height_i <- graphics::strheight(
    main[2],
    units = "inches",
    cex = if ("cex.main" %in% igraph.args) igraph.args$main.cex else NULL
  )*1.5

  graphics::par(
    mfrow = mfrow.par, mar = rep(.25,4),
    omi = c(legend_height_i, 0, main_height_i, 0),
    xpd = NA, xaxs = "i", yaxs="i"
    )

  # Setting igraph defaults
  set_igraph_plotting_defaults("igraph.args")

  # 3. Plotting ----------------------------------------------------------------
  times <- as.integer(names(graph))

  # Set types:
  # - 1: Non adopter
  # - 2: Adopter in s
  # - 3: Adopter prior to s
  set_type <- function() {

    i <- match(s, colnames(cumadopt))
    j <- match(s, slices)

    # If we are looking at the first of both
    if (i==1 & j ==1)
      return(ifelse(!cumadopt[,s], 1L, 2L))

    # Otherwise, we look at something more complicated
    type <- ifelse(!cumadopt[,s] , 1L, NA)

    if (j > 1) {
      type <- ifelse(!is.na(type), type,
                     ifelse(cumadopt[,slices[j-1]], 3L, 2L))
    } else if (i > 1) {
      type <- ifelse(!is.na(type), type,
                     ifelse(cumadopt[, i-1], 3L, 2L))
    }

    type

  }

  for (s in slices) {
    # Colors, new adopters are painted differently

    # Setting color and shape depending on the type of vertex these are.
    type   <- set_type()
    cols   <- vertex.color[type]
    shapes <- vertex.shape[type]

    # Creating igraph object
    ig  <- igraph::graph_from_adjacency_matrix(graph[[s]], weighted = TRUE)

    # Computing layout
    if (!length(igraph.args$layout)) {
      igraph.args$layout <- igraph::layout_nicely(ig)
    } else if (length(igraph.args$layout) && is.function(igraph.args$layout)) {
      igraph.args$layout <- igraph.args$layout(ig)
    }

    # Computing subtitle height
    graphics::plot.new()
    graphics::plot.window(xlim=c(-1.15,1.15), ylim=c(-1.15,1.15))

    # Should we paint or do something else?
    if (is.function(background)) background()
    else if (length(background))
      graphics::rect(-1.15,-1.15,1.15,1.15, col=background, border=background)

    # Plotting
    do.call(
      igraph::plot.igraph,
      c(
      list(
        ig,
        vertex.color = cols,
        vertex.size  = rescale_vertex_igraph(
          compute_vertex_size(graph, vertex.size, match(s, names(graph))),
          minmax.relative.size = minmax.relative.size
          ),
        vertex.shape = shapes
        ),
      igraph.args)
      )

    # Adding a legend (title)
    if (length(main))
      subtitle(x = sprintf(main[1], names(graph[s])))

  }

  # Legend
  graphics::par(
    mfrow = c(1,1), mai = rep(0,4), new = TRUE, xpd=NA,
    omi = c(0, 0, main_height_i, 0)
  )

  # graphics::par(mfrow=c(1,1), new=TRUE, mar=rep(0,4), oma = rep(0,4), xpd=NA)
  graphics::plot.new()
  graphics::plot.window(c(0,1), c(0,1))
  if (length(main) > 1)
    title(main = main[2], outer=TRUE)

  if (length(legend.args))
    do.call(graphics::legend, c(legend.args, list(pt.bg=vertex.color)))

  invisible(igraph.args$layout)

}

#' Threshold levels through time
#'
#' Draws a graph where the coordinates are given by time of adoption, x-axis,
#' and threshold level, y-axis.
#'
#' @templateVar dynamic TRUE
#' @templateVar toa TRUE
#' @templateVar undirected TRUE
#' @template graph_template
#' @param expo \eqn{n\times T}{n * T} matrix. Esposure to the innovation obtained from \code{\link{exposure}}
#' @param t0 Integer scalar. Passed to \code{\link{threshold}}.
#' @param include_censored Logical scalar. Passed to \code{\link{threshold}}.
#' @param attrs Passed to \code{\link{exposure}} (via threshold).
#' @param no.contemporary Logical scalar. When TRUE, edges for vertices with the same
#' \code{toa} won't be plotted.
#' @param main Character scalar. Title of the plot.
#' @param xlab Character scalar. x-axis label.
#' @param ylab Character scalar. y-axis label.
#' @param vertex.size Numeric vector of size \eqn{n}. Relative size of the vertices.
#' @param vertex.color Either a vector of size \eqn{n} or a scalar indicating colors of the vertices.
#' @param vertex.label Character vector of size \eqn{n}. Labels of the vertices.
#' @param vertex.label.pos Integer value to be passed to \code{\link{text}} via \code{pos}.
#' @param vertex.label.cex Either a numeric scalar or vector of size \eqn{n}. Passed to \code{text}.
#' @param vertex.label.adj Passed to \code{\link{text}}.
#' @param vertex.label.color Passed to \code{\link{text}}.
#' @param jitter.amount Numeric vector of size 2 (for x and y) passed to \code{\link{jitter}}.
#' @param jitter.factor Numeric vector of size 2 (for x and y) passed to \code{\link{jitter}}.
#' @param vertex.frame.color Either a vector of size \eqn{n} or a scalar indicating colors of vertices' borders.
#' @param vertex.sides Either a vector of size \eqn{n} or a scalar indicating the
#' number of sides of each vertex (see details).
#' @param vertex.rot Either a vector of size \eqn{n} or a scalar indicating the
#' rotation in radians of each vertex (see details).
#' @param edge.width Numeric. Width of the edges.
#' @param edge.color Character. Color of the edges.
#' @param arrow.width Numeric value to be passed to \code{\link{arrows}}.
#' @param arrow.length Numeric value to be passed to \code{\link{arrows}}.
#' @param arrow.color Color.
#' @param include.grid Logical. When TRUE, the grid of the graph is drawn.
#' @param bty See \code{\link{par}}.
#' @param xlim Passed to \code{\link{plot}}.
#' @param ylim Passed to \code{\link{plot}}.
#' @param ... Additional arguments passed to \code{\link{plot}}.
#' @param edge.curved Logical scalar. When curved, generates curved edges.
#' @param background TBD
#' @family visualizations
#' @seealso Use \code{\link{threshold}} to retrieve the corresponding threshold
#' obtained returned by \code{\link{exposure}}.
#' @keywords hplot
#'
#' @details When \code{vertex.label=NULL} the function uses vertices ids as labels.
#' By default \code{vertex.label=""} plots no labels.
#'
#' Vertices are drawn using an internal function for generating polygons.
#' Polygons are inscribed in a circle of radius \code{vertex.size}, and can be
#' rotated using \code{vertex.rot}. The number of sides of each polygon
#' is set via \code{vertex.sides}.
#'
#' @examples
#'
#' # Generating a random graph
#' set.seed(1234)
#' n <- 6
#' nper <- 5
#' graph <- rgraph_er(n,nper, p=.3, undirected = FALSE)
#' toa <- sample(2000:(2000+nper-1), n, TRUE)
#' adopt <- toa_mat(toa)
#'
#' # Computing exposure
#' expos <- exposure(graph, adopt$cumadopt)
#'
#' plot_threshold(graph, expos, toa)
#'
#' # Calculating degree (for sizing the vertices)
#' plot_threshold(graph, expos, toa, vertex.size = "indegree")
#'
#' @export
#' @author George G. Vega Yon
plot_threshold <- function(graph, expo, ...) UseMethod("plot_threshold")

#' @export
#' @rdname plot_threshold
plot_threshold.diffnet <- function(graph, expo, ...) {
  # If graph is diffnet, then we should do something different (because the
  # first toa may not be the firts one as toa may be stacked to the right.
  # see ?as_diffnet)
  # graph$toa <- graph$toa - min(graph$meta$pers) + 1L

  if (missing(expo))
    expo <- exposure(graph)

  args <- list(...)

  if (!length(args$undirected)) args$undirected <- graph$meta$undirected
  if (!length(args$t0)) args$t0 <- graph$meta$pers[1]
  if (length(args$toa)) {
    warning("While -graph- has its own toa variable, the user is providing one.")
  } else {
    args$toa <- graph$toa
  }

  do.call(plot_threshold.default, c(list(graph = graph$graph, expo=expo), args))
}

#' @export
#' @rdname plot_threshold
plot_threshold.array <- function(graph, expo, ...) {
  plot_threshold.default(as_dgCMatrix(graph), expo = expo, ...)
}

#' @export
#' @rdname plot_threshold
plot_threshold.default <- function(
  graph,
  expo,
  toa,
  include_censored = FALSE,
  t0               = min(toa, na.rm = TRUE),
  attrs            = NULL,
  undirected       = getOption("diffnet.undirected"),
  no.contemporary  = TRUE,
  main             = "Time of Adoption by\nNetwork Threshold",
  xlab             = "Time",
  ylab             = "Threshold",
  vertex.size      = "degree",
  vertex.color     = NULL,
  vertex.label     = "",
  vertex.label.pos = NULL,
  vertex.label.cex = 1,
  vertex.label.adj = c(.5,.5),
  vertex.label.color = NULL,
  vertex.sides     = 40L,
  vertex.rot       = 0,
  edge.width       = 2,
  edge.color       = NULL,
  arrow.width      = NULL,
  arrow.length     = NULL,
  arrow.color      = NULL,
  include.grid     = FALSE,
  vertex.frame.color = NULL,
  bty              = "n",
  jitter.factor    = c(1,1),
  jitter.amount    = c(.25,.025),
  xlim             = NULL,
  ylim             = NULL,
  edge.curved      = NULL,
  background       = NULL,
  ...
  ) {

  # Setting default parameters
  set_plotting_defaults(c("edge.color", "vertex.frame.color", "vertex.label.color", "edge.curved", "vertex.color", "background", "arrow.color"))

  # # Checking out defaults
  # if (!length(edge.color)) edge.color <- igraph_plotting_defaults$edge.color
  # if (!length(edge.color)) edge.color <- igraph_plotting_defaults$vertex.frame.color

  # Checking if exposure was provided
  if (missing(expo))
    stop("expo should be provided")

  # Checking the type of graph
  graph <- as_dgCMatrix(graph)

  # Step 0: Getting basic info
  t <- length(graph)
  n <- nrow(graph[[1]])

  # Step 1: Creating the cumulative graph
  # Matrix::sparseMatrix(i={}, j={}, dims=c(n, n))
  cumgraph <- methods::new("dgCMatrix", Dim=c(n,n), p=rep(0L, n+1L))
  for(i in 1:t) {
    cumgraph <- cumgraph + graph[[i]]
  }

  # Creating the pos vector
  y0 <- threshold(expo, toa, t0, attrs=attrs, include_censored=include_censored)
  y <- jitter(y0, factor=jitter.factor[2], amount = jitter.amount[2])

  # Jitter to the xaxis and limits
  jit <- jitter(toa, factor=jitter.factor[1], amount = jitter.amount[1])
  xran <- range(toa, na.rm = TRUE)
  if (!length(xlim)) xlim <- xran + c(-1,1)
  yran <- c(0,1)
  if (!length(ylim)) ylim <- yran + (yran[2] - yran[1])*.1*c(-1,1)

  # Step 2: Checking colors and sizes

  # Computing sizes
  vertex.size <- compute_vertex_size(graph, vertex.size)

  # Checking sides
  test <- length(vertex.sides)
  if (!inherits(vertex.sides, c("integer", "numeric"))) {
    stop("-vertex.sides- must be integer.")
  } else if (inherits(vertex.sides, "numeric")) {
    warning("-vertex.sides- will be coerced to integer.")
    vertex.sides <- as.integer(vertex.sides)
  }

  if (test == 1) {
    vertex.sides <- rep(vertex.sides, n)
  } else if (test != n) {
    stop("-vertex.sides- must be of the same length as nnodes(graph).")
  }

  # Checking Rotation
  test <- length(vertex.rot)
  if (!inherits(vertex.rot, "integer") & !inherits(vertex.rot, "numeric")) {
    stop("-vertex.rot- must be numeric.")
  } else if (test == 1) {
    vertex.rot <- rep(vertex.rot, n)
  } else if (test != n) {
    stop("-vertex.rot- must be of the same length as nnodes(graph).")
  }

  # Plotting
  # oldpar <- par(no.readonly = TRUE)
  graphics::plot(NULL, xlim=xlim, ylim=ylim, xlab=xlab, ylab=ylab, main=main,
       xaxs="i", yaxs="i",...)

  # Should we paint or do something else?
  if (is.function(background)) background()
  else if (length(background))
    graphics::rect(xlim[1], ylim[1], xlim[2], ylim[2], col=background, border=background)

  # Checking
  if (!length(arrow.width))
    arrow.width <- with(graphics::par(), (usr[2] - usr[1])/75)

  if (!length(arrow.length))
    arrow.length <- with(graphics::par(), (usr[2] - usr[1])/75)

  # Should there be a grid??
  if (include.grid)
    grid()

  # Now, for y (it should be different)
  xran <- range(xlim, na.rm = TRUE)
  yran <- range(ylim, na.rm = TRUE)

  # Drawing arrows, first we calculate the coordinates of the edges, for this we
  # use the function edges_coords. This considers aspect ratio of the plot.
  vertex.size <- igraph_vertex_rescale(vertex.size, adjust=1)
  edges <- edges_coords(cumgraph, toa, jit, y, vertex.size, undirected, no.contemporary,
                        dev=par("pin"), ran=c(xlim[2]-xlim[1], ylim[2]-ylim[1]))
  edges <- as.data.frame(edges)

  ran  <- c(xlim[2]-xlim[1], ylim[2]-ylim[1])

  # Plotting the edges
  mapply(function(x0, y0, x1, y1, col, edge.curved, arrow.color) {
    y <- edges_arrow(x0, y0, x1, y1, width=arrow.width, height=arrow.length,
                     beta=pi*(2/3), dev=par("pin"), ran=ran, curved = edge.curved)

    # Drawing arrow
    if (edge.curved) {

      # Edge
      graphics::xspline(
        y$edge[,1],y$edge[,2],
        shape = c(0, 1, 0),
        open=TRUE, border = col, lwd=edge.width)

      # Arrow
      graphics::polygon(y$arrow[,1], y$arrow[,2], col = arrow.color, border = arrow.color)
    } else {
      # Edge
      graphics::polygon(y$edge[,1],y$edge[,2], col = col, border = col, lwd=edge.width)

      # Arrow
      graphics::polygon(y$arrow[,1], y$arrow[,2], col = arrow.color, border = arrow.color)
    }

  }, x0 = edges[,"x0"], y0 = edges[,"y0"], x1 = edges[,"x1"], y1 = edges[,"y1"],
  col = edge.color, edge.curved = edge.curved, arrow.color=arrow.color)

  # Drawing the vertices and its labels
  # Computing the coordinates
  pol <- vertices_coords(jit, y, vertex.size, vertex.sides, vertex.rot, par("pin"), ran)

  # Plotting
  mapply(function(coords,border,col)
    graphics::polygon(coords[,1], coords[,2], border = border, col=col),
    coords = pol, border = vertex.frame.color, col=vertex.color)

  # Positioning labels can be harsh, so we try with this algorithm
  if (!length(vertex.label)) vertex.label <- 1:n
  graphics::text(x=jit, y=y, labels = vertex.label,
       pos = vertex.label.pos,
       cex = vertex.label.cex,
       col = vertex.label.color,
       adj = vertex.label.adj
       )

  # par(oldpar)

  invisible(data.frame(toa=toa,threshold=y0, jit=jit))

}

#' Plot distribution of infect/suscep
#'
#' After calculating infectiousness and susceptibility of each individual on the
#' network, it creates an \code{nlevels} by \code{nlevels} matrix indicating the
#' number of individuals that lie within each cell, and draws a heatmap.
#'
#' @templateVar dynamic TRUE
#' @templateVar toa TRUE
#' @template graph_template
#' @param t0 Integer scalar. See \code{\link{toa_mat}}.
#' @param normalize Logical scalar.  Passed to infection/susceptibility.
#' @param K Integer scalar.  Passed to infection/susceptibility.
#' @param r Numeric scalar.  Passed to infection/susceptibility.
#' @param expdiscount Logical scalar.  Passed to infection/susceptibility.
#' @param bins Integer scalar. Size of the grid (\eqn{n}).
#' @param nlevels Integer scalar. Number of levels to plot (see \code{\link{filled.contour}}).
#' @param h Numeric vector of length 2. Passed to \code{\link[MASS:kde2d]{kde2d}} in the \pkg{MASS} package.
#' @param logscale Logical scalar. When TRUE the axis of the plot will be presented in log-scale.
#' @param main Character scalar. Title of the graph.
#' @param xlab Character scalar. Title of the x-axis.
#' @param ylab Character scalar. Title of the y-axis.
#' @param sub Character scalar. Subtitle of the graph.
#' @param color.palette a color palette function to be used to assign colors in the plot (see \code{\link{filled.contour}}).
#' @param include.grid Logical scalar. When TRUE, the grid of the graph is drawn.
#' @param ... Additional parameters to be passed to \code{\link{filled.contour}.}
#' @param exclude.zeros Logical scalar. When TRUE, observations with zero values
#' @param valued Logical scalar. When FALSE non-zero values in the adjmat are set to one.
#' in infect or suscept are excluded from the graph. This is done explicitly when \code{logscale=TRUE}.
#' @details
#'
#' This plotting function was inspired by Aral, S., & Walker, D. (2012).
#'
#' By default the function will try to apply a kernel smooth function via
#' \code{kde2d}. If not possible (because not enought data points), then
#' the user should try changing the parameter \code{h} or set it equal to zero.
#'
#' \code{toa} is passed to \code{infection/susceptibility}.
#'
#' @return A list with three elements:
#' \item{infect}{A numeric vector of size \eqn{n} with infectiousness levels}
#' \item{suscep}{A numeric vector of size \eqn{n} with susceptibility levels}
#' \item{coords}{A list containing the class marks and counts used to draw the
#' plot via \code{\link{filled.contour}} (see \code{\link{grid_distribution}})}
#' \item{complete}{A logical vector with \code{TRUE} when the case was included in
#' the plot. (this is relevant whenever \code{logscale=TRUE})}
#' @family visualizations
#' @seealso Infectiousness and susceptibility are computed via \code{\link{infection}} and
#' \code{\link{susceptibility}}.
#' @keywords hplot
#' @references
#' Aral, S., & Walker, D. (2012). "Identifying Influential and Susceptible Members
#' of Social Networks". Science, 337(6092), 337–341.
#' \doi{10.1126/science.1215842}
#' @export
#' @examples
#' # Generating a random graph -------------------------------------------------
#' set.seed(1234)
#' n <- 100
#' nper <- 20
#' graph <- rgraph_er(n,nper, p=.2, undirected = FALSE)
#' toa <- sample(1:(1+nper-1), n, TRUE)
#'
#' # Visualizing distribution of suscep/infect
#' out <- plot_infectsuscep(graph, toa, K=3, logscale = FALSE)
#' @author George G. Vega Yon
plot_infectsuscep <- function(
  graph,
  toa,
  t0            = NULL,
  normalize     = TRUE,
  K             = 1L,
  r             = 0.5,
  expdiscount   = FALSE,
  bins          = 20,
  nlevels       = round(bins/2),
  h             = NULL,
  logscale      = TRUE,
  main          = "Distribution of Infectiousness and\nSusceptibility",
  xlab          = "Infectiousness of ego",
  ylab          = "Susceptibility of ego",
  sub           = ifelse(logscale, "(in log-scale)", NA),
  color.palette = function(n) viridisLite::viridis(n),
  include.grid  = TRUE,
  exclude.zeros = FALSE,
  valued        = getOption("diffnet.valued",FALSE),
  ...
) {

  # Checking the times argument
  if (missing(toa))
    if (!inherits(graph, "diffnet")) {
      stop("-toa- should be provided when -graph- is not of class 'diffnet'")
    } else {
      toa <- graph$toa
      t0    <- min(graph$meta$pers)
    }

  if (!length(t0)) t0 <- min(toa, na.rm = TRUE)

  cls <- class(graph)

  if ("array" %in% cls) {
    plot_infectsuscep.array(
      graph, toa, t0, normalize, K, r, expdiscount, bins, nlevels, h, logscale, main,
      xlab, ylab, sub, color.palette, include.grid, exclude.zeros, valued, ...)
  } else if ("list" %in% cls) {
    plot_infectsuscep.list(
      graph, toa, t0, normalize, K, r, expdiscount, bins, nlevels, h, logscale, main,
      xlab, ylab, sub, color.palette, include.grid, exclude.zeros, valued,...)
  } else if ("diffnet" %in% cls) {
    plot_infectsuscep.list(
      graph$graph, graph$toa, t0, normalize, K, r, expdiscount, bins, nlevels, h, logscale, main,
      xlab, ylab, sub, color.palette, include.grid, exclude.zeros, valued,...)
  } else
    stopifnot_graph(graph)

}

# @export
# @rdname plot_infectsuscep
plot_infectsuscep.array <- function(graph, ...) {
  graph <- apply(graph, 3, methods::as, Class="dgCMatrix")
  plot_infectsuscep.list(graph, ...)
}

# @export
# @rdname plot_infectsuscep
plot_infectsuscep.list <- function(graph, toa, t0, normalize,
                              K, r, expdiscount,
                              bins,nlevels,
                              h,
                              logscale,
                              main,
                              xlab,
                              ylab,
                              sub,
                              color.palette,
                              include.grid, exclude.zeros, valued,
                              ...) {
  # Computing infect and suscept
  infect <- infection(graph, toa, t0, normalize, K, r, expdiscount, valued)
  suscep <- susceptibility(graph, toa, t0, normalize, K, r, expdiscount, valued)
  complete <- complete.cases(infect, suscep)

  # Performing classification (linear)
  if (logscale) {
    infectp<-log(infect)
    suscepp<-log(suscep)

    # Only keeping complete cases
    complete <- complete & is.finite(infectp) & is.finite(suscepp)

    if (any(!complete)) warning("When applying logscale some observations are missing.")
  }
  else {
    infectp <- infect
    suscepp <- suscep
  }

  infectp <- infectp[complete,]
  suscepp <- suscepp[complete,]

  if ((!length(infectp) | !length(suscepp)) & logscale)
    stop("Can't apply logscale (undefined values).")

  # If excluding zeros
  include <- rep(TRUE,length(infectp))
  if (exclude.zeros) {
    include[!infectp | !suscepp] <- FALSE
  }

  # Computing infect & suscept
  if (length(h) && h==0) {
    coords <- grid_distribution(infectp[include], suscepp[include], bins)
  } else {
    if (!length(h)) h <- c(
      MASS::bandwidth.nrd(infectp[include & infectp!=0]),
      MASS::bandwidth.nrd(suscepp[include & suscepp!=0])
      )

    # Cant use smoother
    if (any((h==0) | is.na(h)))
      stop('Not enought data to perform smooth. Try choosing another value for -h-,',
           ' or set h=0 (no kernel smooth).')
    coords <- MASS::kde2d(infectp[include], suscepp[include], n = bins, h = h)
  }

  # Nice plot

  n <- sum(coords$z)
  with(coords, filled.contour(
    x,y,
    z/n, bty="n", main=main, xlab=xlab, ylab=ylab, sub=sub, color.palette =color.palette,
    xlim=range(x), ylim=range(y),
    plot.axes={

      # Preparing the tickmarks for the axis
      xticks  <- pretty(x)
      yticks  <- pretty(y)
      if (logscale) {
        xlticks <- exp(xticks)
        ylticks <- exp(yticks)
      } else {
        xlticks <- xticks
        ylticks <- yticks
      }

      # Drawing the axis
      axis(1, xticks, sprintf("%.2f",xlticks))
      axis(2, yticks, sprintf("%.2f",ylticks))

      # Putting the grid
      if (include.grid) grid()
    }, nlevels=nlevels, ...))
  # if (include.grid) grid()

  # Adding some reference
  legend("topleft", legend=
         sprintf('\n%d out of %d obs.\nincluded', sum(include), length(complete)),
         bty="n")

  invisible(list(infect=infect, suscept=suscep, coords=coords,
                 complete=complete))
}

#' Visualize adopters and cumulative adopters
#' @param obj Either a diffnet object or a cumulative a doption matrix.
#' @param freq Logical scalar. When TRUE frequencies are plotted instead of proportions.
#' @param what Character vector of length 2. What to plot.
#' @param add Logical scalar. When TRUE lines and dots are added to the current graph.
#' @param include.legend Logical scalar. When TRUE a legend of the graph is plotted.
#' @param pch Integer vector of length 2. See \code{\link{matplot}}.
#' @param type Character vector of length 2. See \code{\link{matplot}}.
#' @param ylim Numeric vector of length 2. Sets the plotting limit for the y-axis.
#' @param lty Numeric vector of length 2. See \code{\link{matplot}}.
#' @param col Character vector of length 2. See \code{\link{matplot}}.
#' @param bg Character vector of length 2. See \code{\link{matplot}}.
#' @param xlab Character scalar. Name of the x-axis.
#' @param ylab Character scalar. Name of the y-axis.
#' @param main Character scalar. Title of the plot
#' @param ... Further arguments passed to \code{\link{matplot}}.
#' @param include.grid Logical scalar. When TRUE, the grid of the graph is drawn
#' @family visualizations
#' @examples
#' # Generating a random diffnet -----------------------------------------------
#' set.seed(821)
#' diffnet <- rdiffnet(100, 5, seed.graph="small-world", seed.nodes="central")
#'
#' plot_adopters(diffnet)
#'
#' # Alternatively, we can use a TOA Matrix
#' toa <- sample(c(NA, 2010L,2015L), 20, TRUE)
#' mat <- toa_mat(toa)
#' plot_adopters(mat$cumadopt)
#' @return A matrix as described in \code{\link{cumulative_adopt_count}}.
#' @export
#' @author George G. Vega Yon
plot_adopters <- function(
  obj,
  freq           = FALSE,
  what           = c("adopt","cumadopt"),
  add            = FALSE,
  include.legend = TRUE,
  include.grid   = TRUE,
  pch            = c(21,24),
  type           = c("b", "b"),
  ylim           = if (!freq) c(0,1) else NULL,
  lty            = c(1,1),
  col            = c("black","black"),
  bg             = c("tomato","gray"),
  xlab           = "Time",
  ylab           = ifelse(freq, "Frequency", "Proportion"),
  main           = "Adopters and Cumulative Adopters",
  ...
  ) {

  # Checking what
  if (any(!(what %in% c("adopt", "cumadopt"))))
    stop("Invalid curve to plot. -what- must be in c(\"adopt\",\"cumadopt\").")

  # Computing the TOA mat
  if (inherits(obj, "diffnet")) {
    cumadopt <- cumulative_adopt_count(obj)
    adopt    <- colSums(obj$adopt)
    n        <- obj$meta$n
  }
  else {
    cumadopt <- cumulative_adopt_count(obj)
    adopt    <- cumadopt["num",] - c(0,cumadopt["num",1:(ncol(cumadopt)-1)])
    n        <- nrow(obj)
  }

  out <- cumadopt

  # In the case that the user wants pcent (the default)
  if (!freq) {
    cumadopt <- cumadopt/n
    adopt    <- adopt/n
  }

  # Time names...
  times <- colnames(cumadopt)
  if ((length(ylim) == 1) && is.na(ylim))
    ylim <- NULL

  # Building matrix to plot
  k <- length(what)
  n <- length(times)
  mat <- matrix(ncol=k, nrow=n)
  if ("cumadopt" %in% what) mat[,1] <- cumadopt["num",]
  if ("adopt" %in% what) mat[,k] <- adopt

  # Fixing parameters
  test <- c("cumadopt" %in% what, "adopt" %in% what)
  if (length(type) > k) type <- type[test]
  if (length(lty)  > k) lty  <- lty[test]
  if (length(col)  > k) col  <- col[test]
  if (length(bg)   > k) bg   <- bg[test]
  if (length(pch)  > k) pch  <- pch[test]

  matplot(times, y=mat, ylim=ylim, add=add, type=type,
          lty=lty, col=col, xlab=xlab, ylab=ylab, main=main, pch=pch,
          bg=bg,...)

  # If not been added
  if (!add) {
    if (include.legend)
      legend("topleft", bty="n", pch=pch,
             legend = c("Cumulative adopters", "Adopters")[test], pt.bg = bg, col=col)

    if (include.grid)
      grid()
  }

  invisible(out)
}

# x <- cumulative_adopt_count(diffnet)
# z <- x["num",] - c(0,x["num",1:(ncol(x)-1)])
# cumsum(z)
# x["num",]

#' \code{diffnet} Arithmetic and Logical Operators
#'
#' Addition, subtraction, network power of diffnet and logical operators such as
#' \code{&} and \code{|} as objects
#'
#' @param x A \code{diffnet} class object.
#' @param y Integer scalar. Power of the network
#' @param valued Logical scalar. When FALSE all non-zero entries of the adjacency
#' matrices are set to one.
#'
#' @details Using binary operators, ease data management process with diffnet.
#'
#' By default the binary operator \code{^} assumes that the graph is valued,
#' hence the power is computed using a weighted edges. Otherwise, if more control
#' is needed, the user can use \code{graph_power} instead.
#'
#' @return A diffnet class object
#'
#' @examples
#' # Computing two-steps away threshold with the Brazilian farmers data --------
#' data(brfarmersDiffNet)
#'
#' expo1 <- threshold(brfarmersDiffNet)
#' expo2 <- threshold(brfarmersDiffNet^2)
#'
#' # Computing correlation
#' cor(expo1,expo2)
#'
#' # Drawing a qqplot
#' qqplot(expo1, expo2)
#'
#' # Working with inverse ------------------------------------------------------
#' brf2_step <- brfarmersDiffNet^2
#' brf2_step <- 1/brf2_step
#'
#' @export
#' @name diffnet-arithmetic
#' @family diffnet methods
`^.diffnet` <- function(x,y) {

  if (y < 2) return(x)

  for (i in 1:x$meta$nper) {
    g <- x$graph[[i]]
    for (p in 1:(y-1))
      x$graph[[i]] <- x$graph[[i]] %*% g
  }
  x
}

#' @rdname diffnet-arithmetic
#' @export
graph_power <- function(x, y, valued=getOption("diffnet.valued", FALSE)) {
  # If no valued
  if (!valued)
    for (i in 1:x$meta$nper)
      x$graph[[i]]@x <- rep(1, length(x$graph[[i]]@x))

  x^y
}

#' @rdname diffnet-arithmetic
#' @export
`/.diffnet` <- function(y, x) {

  if (inherits(x, "diffnet") && (inherits(y, "numeric") | inherits(y, "integer"))) {
    for (i in 1:x$meta$nper)
      x$graph[[i]]@x <- y/(x$graph[[i]]@x)
    return(x)
  } else if (inherits(y, "diffnet") && (inherits(x, "numeric") | inherits(x, "integer"))) {
    for (i in 1:y$meta$nper)
      y$graph[[i]]@x <- x/(y$graph[[i]]@x)
    return(y)
  } else stop("No method for x:", class(x), " and y:", class(y))

}

#' @rdname diffnet-arithmetic
#' @export
#' @examples
#' # Removing the first 3 vertex of medInnovationsDiffnet ----------------------
#' data(medInnovationsDiffNet)
#'
#' # Using a diffnet object
#' first3Diffnet <- medInnovationsDiffNet[1:3,,]
#' medInnovationsDiffNet - first3Diffnet
#'
#' # Using indexes
#' medInnovationsDiffNet - 1:3
#'
#' # Using ids
#' medInnovationsDiffNet - as.character(1001:1003)
`-.diffnet` <- function(x, y) {
  if (inherits(x, "diffnet") & inherits(y, "diffnet")) {

    # Listing the id numbers that wont be removed
    ids.to.remove <- y$meta$ids
    ids.to.remove <- which(x$meta$ids %in% ids.to.remove)
    x[-ids.to.remove, , drop=FALSE]
  } else if (inherits(x, "diffnet") & any(class(y) %in% c("integer", "numeric"))) {

    # Dropping using ids
    x[-y,, drop=FALSE]
  } else if (inherits(x, "diffnet") & inherits(y, "character")) {
    # Checking labels exists
    test <- which(!(y %in% x$meta$ids))
    if (length(test))
      stop("Some elements in -y- (right-hand side of the expression) are not ",
           "in the set of ids of the diffnet object:\n\t",
           paste0(y[test], collapse=", "),".")

    y <- which(x$meta$ids %in% y)
    x[-y,,drop=FALSE]
  } else
    stop("Subtraction between -",class(x),"- and -", class(y), "- not supported.")
}

#' @export
#' @rdname diffnet-arithmetic
`*.diffnet` <- function(x,y) {
  if (inherits(x, "diffnet") & inherits(y, "diffnet")) {

    # Checking dimensions
    test <- all(dim(x) == dim(y))
    if (!test)
      stop('Both -x- and -y- must have the same dimensions.')

    x$graph <- mapply(`*`, x$graph, y$graph)
    return(x)
  } else if (inherits(x, "diffnet") & is.numeric(y)) {
    x$graph <- mapply(`*`, x$graph, y)
    return(x)

  } else
    stop("Multiplication between -",class(x),"- and -", class(y), "- not supported.")
}

#' @export
#' @rdname diffnet-arithmetic
`&.diffnet` <- function(x,y) {
  x$graph <- mapply(function(a,b) methods::as(a & b, "dgCMatrix"), x$graph, y$graph)
  x
}

#' @export
#' @rdname diffnet-arithmetic
`|.diffnet` <- function(x,y) {
  x$graph <- mapply(function(a,b) methods::as(a | b, "dgCMatrix"), x$graph, y$graph)
  x
}

#' Matrix multiplication
#'
#' Matrix multiplication methods, including \code{\link{diffnet}}
#' objects. This function creates a generic method for \code{\link[base:matmult]{\%*\%}}
#' allowing for multiplying diffnet objects.
#'
#' @param x Numeric or complex matrices or vectors, or \code{diffnet} objects.
#' @param y Numeric or complex matrices or vectors, or \code{diffnet} objects.
#'
#' @details This function can be usefult to generate alternative graphs, for
#' example, users could compute the n-steps graph by doing \code{net \%*\% net}
#' (see examples).
#'
#' @return In the case of \code{diffnet} objects performs matrix multiplication
#' via \code{\link{mapply}} using \code{x$graph} and \code{y$graph} as arguments,
#' returnling a \code{diffnet}. Otherwise returns the default according to
#' \code{\link[base:matmult]{\%*\%}}.
#'
#' @examples
#' # Finding the Simmelian Ties network ----------------------------------------
#'
#' # Random diffnet graph
#' set.seed(773)
#' net <- rdiffnet(100, 4, seed.graph='small-world', rgraph.args=list(k=8))
#' netsim <- net
#'
#' # According to Dekker (2006), Simmelian ties can be computed as follows
#' netsim <- net * t(net) # Keeping mutal
#' netsim <- netsim * (netsim %*% netsim)
#'
#' # Checking out differences (netsim should have less)
#' nlinks(net)
#' nlinks(netsim)
#'
#' mapply(`-`, nlinks(net), nlinks(netsim))
#'
#' @export
#' @rdname diffnetmatmult
#' @family diffnet methods
`%*%` <- function(x, y) UseMethod("%*%")

#' @export
#' @rdname diffnetmatmult
`%*%.default` <- function(x, y) {
  if (inherits(y, "diffnet")) `%*%.diffnet`(x,y)
  else base::`%*%`(x=x,y=y)
}

#' @export
#' @rdname diffnetmatmult
`%*%.diffnet` <- function(x, y) {

  mat2dgCList <- function(w,z) {
    w <- lapply(seq_len(nslices(z)), function(u) methods::as(w, "dgCMatrix"))
    names(w) <- dimnames(z)[[3]]
    w
  }

  if (inherits(x, "diffnet") && inherits(y, "diffnet")) {
    x$graph <- mapply(base::`%*%`, x$graph, y$graph)
  } else if (inherits(x, "diffnet") && !inherits(y, "diffnet")) {
    if (identical(rep(dim(x)[1],2), dim(y)))
      x$graph <- mapply(base::`%*%`, x$graph, mat2dgCList(y, x))
    else stop("-y- must have the same dimension as -x-")
  } else if (inherits(y, "diffnet") && !inherits(x, "diffnet")) {
    if (identical(rep(dim(y)[1],2), dim(x))) {
      y$graph <- mapply(base::`%*%`, mat2dgCList(x, y), y$graph)
      return(y)
    }
    else stop("-y- must have the same dimension as -x-")
  }

  x
}

#' Coerce a diffnet graph into an array
#'
#' @param x A diffnet object.
#' @param ... Ignored.
#' @details
#' The function takes the list of sparse matrices stored in \code{x} and creates
#' an array with them. Attributes and other elements from the diffnet object are
#' dropped.
#'
#' \code{dimnames} are obtained from the metadata of the diffnet object.
#'
#' @return A three-dimensional array of \eqn{T} matrices of size \eqn{n\times n}{n * n}.
#' @seealso \code{\link{diffnet}}.
#' @family diffnet methods
#' @examples
#' # Creating a random diffnet object
#' set.seed(84117)
#' mydiffnet <- rdiffnet(30, 5)
#'
#' # Coercing it into an array
#' as.array(mydiffnet)
#' @export
as.array.diffnet <- function(x, ...) {
  # Coercing into matrices
  z <- lapply(x$graph, function(y) {
    as.matrix(y)
  })

  # Creating the array
  out <- with(x$meta, array(dim=c(n, n, nper)))
  for (i in 1:length(z))
    out[,,i] <- z[[i]]

  # Naming dimensions
  dimnames(out) <- with(x$meta, list(ids, ids, pers))
  out
}

#' Count the number of vertices/edges/slices in a graph
#'
#' @template graph_template
#' @return For \code{nvertices} and \code{nslices}, an integer scalar equal to the number
#' of vertices and slices in the graph. Otherwise, from \code{nedges}, either a list
#' of size \eqn{t} with the counts of edges (non-zero elements in the adjacency matrices) at
#' each time period, or, when \code{graph} is static, a single scalar with
#' such number.
#' @details
#' \code{nnodes} and \code{nlinks} are just aliases for \code{nvertices} and
#' \code{nedges} respectively.
#' @export
#' @examples
#' # Creating a dynamic graph (we will use this for all the classes) -----------
#' set.seed(13133)
#' diffnet <- rdiffnet(100, 4)
#'
#' # Lets use the first time period as a static graph
#' graph_mat <- diffnet$graph[[1]]
#' graph_dgCMatrix <- methods::as(graph_mat, "dgCMatrix")
#'
#' # Now lets generate the other dynamic graphs
#' graph_list  <- diffnet$graph
#' graph_array <- as.array(diffnet) # using the as.array method for diffnet objects
#'
#' # Now we can compare vertices counts
#' nvertices(diffnet)
#' nvertices(graph_list)
#' nvertices(graph_array)
#'
#' nvertices(graph_mat)
#' nvertices(graph_dgCMatrix)
#'
#' # ... and edges count
#' nedges(diffnet)
#' nedges(graph_list)
#' nedges(graph_array)
#'
#' nedges(graph_mat)
#' nedges(graph_dgCMatrix)
nvertices <- function(graph) {

  cls <- class(graph)

  if (any(c("array", "matrix", "dgCMatrix") %in% cls)) {
    nrow(graph)
  } else if ("list" %in% cls) {
    nrow(graph[[1]])
  } else if ("diffnet" %in% cls) {
    graph$meta$n
  } else if ("igraph" %in% cls) {
    igraph::vcount(graph)
  } else if ("network" %in% cls) {
    network::network.size(graph)
  } else
    stopifnot_graph(graph)

}

#' @rdname nvertices
#' @export
nnodes <- nvertices

#' @export
#' @rdname nvertices
nedges <- function(graph) {

  cls <- class(graph)

  if ("matrix" %in% cls) {
    sum(graph != 0)
  } else if ("array" %in% cls) {
    # Computing and coercing into a list
    x <- as.list(apply(graph, 3, function(x) sum(x!=0)))

    # Naming
    tnames <- names(x)
    if (!length(tnames)) names(x) <- 1:length(x)
    x

  } else if ("dgCMatrix" %in% cls) {
    length(graph@i)
  } else if ("list" %in% cls) {

    # Computing
    x <- lapply(graph, function(x) length(x@i))

    # Naming
    tnames <- names(x)
    if (!length(tnames)) names(x) <- 1:length(x)
    x

  } else if ("diffnet" %in% cls) {
    lapply(graph$graph, function(x) sum(x@x != 0))
  } else if ("igraph" %in% cls) {
    igraph::ecount(graph)
  } else if ("network" %in% cls) {
    network::network.edgecount(graph)
  } else
    stopifnot_graph(graph)

}

#' @export
#' @rdname nvertices
nlinks <- nedges

#' @export
#' @rdname nvertices
nslices <- function(graph) {

  cls <- class(graph)

  if ("matrix" %in% cls) {
    1L
  } else if ("array" %in% cls)  {
    dim(graph)[3]
  } else if ("dgCMatrix" %in% cls)  {
    1L
  } else if ("diffnet" %in% cls)  {
    graph$meta$nper
  } else if ("list" %in% cls) {
    length(graph)
  } else
    stopifnot_graph(graph)

}

#' @export
#' @rdname diffnet-class
nodes <- function(graph) {
  cls <- class(graph)
  if ("diffnet" %in% cls)
    return(graph$meta$ids)
  else if ("list" %in% cls) {
    ans <- rownames(graph[[1]])
    if (!length(ans)) stop("There are not names to fetch")
    else return(ans)
  } else if (any(c("matrix", "dgCMatrix", "array") %in% cls)) {
    ans <- rownames(graph)
    if (!length(ans)) stop("There are not names to fetch")
    else return(ans)
  }
  else stopifnot_graph(graph)

}

#' @export
#' @rdname diffnet-class
#' @param FUN a function to be passed to lapply
diffnetLapply <- function(graph, FUN, ...) {
  lapply(seq_len(nslices(graph)), function(x, graph, ...) {
    FUN(x,
        graph               = graph$graph[[x]],
        toa                 = graph$toa,
        vertex.static.attrs = graph$vertex.static.attrs,
        vertex.dyn.attrs    = graph$vertex.dyn.attrs[[x]],
        adopt               = graph$adopt[,x,drop=FALSE],
        cumadopt            = graph$cumadopt[,x,drop=FALSE],
        meta                = graph$meta)
    }, graph=graph,...)
}
# debug(diffnetLapply)
# diffnetLapply(medInnovationsDiffNet, function(x, graph, cumadopt, ...) {
#   sum(cumadopt)
# })

#' @export
#' @rdname diffnet-class
str.diffnet <- function(object, ...) {
  utils::str(unclass(object))
}

#' @export
#' @rdname diffnet-class
dimnames.diffnet <- function(x) {
  with(x, list(
    meta$ids,
    c(colnames(vertex.static.attrs), names(vertex.dyn.attrs[[1]])),
    meta$pers)
  )
}

#' @export
#' @rdname diffnet-class
#' @method t diffnet
t.diffnet <- function(x) {
  x$graph <- lapply(x$graph, getMethod("t", "dgCMatrix"))
  x
}

#' @rdname diffnet-class
#' @export
dim.diffnet <- function(x) {
  k <- length(with(x, c(colnames(vertex.static.attrs), names(vertex.dyn.attrs[[1]]))))
  as.integer(with(x$meta, c(n, k, nper)))
}