From 1e04bd15de30f46bd1ec08ce70c6e0266ad4f1d5 Mon Sep 17 00:00:00 2001 From: Theo Pannetier Date: Mon, 29 Mar 2021 16:05:39 +0200 Subject: [PATCH 01/49] extend conditions to more four-parameter DD models --- R/dd_ML.R | 55 ++++--- R/dd_loglik.R | 349 ++++++++++++++++++++-------------------- R/dd_loglik_choosepar.R | 7 +- 3 files changed, 215 insertions(+), 196 deletions(-) diff --git a/R/dd_ML.R b/R/dd_ML.R index 8d2c322..da72a62 100644 --- a/R/dd_ML.R +++ b/R/dd_ML.R @@ -157,22 +157,30 @@ dd_ML = function( { stop('Please specify a tolerance vector with three values') } + both_rates_vary <- ddmodel %in% c(5:8, 11:13) + if (both_rates_vary) { + output_error <- data.frame(lambda = -1,mu = -1,K = -1, r = -1, loglik = -1, df = -1, conv = -1) + } else { + output_error <- data.frame(lambda = -1,mu = -1,K = -1, loglik = -1, df = -1, conv = -1) + } + brts = sort(abs(as.numeric(brts)),decreasing = TRUE) - if(is.numeric(brts) == FALSE) + if (is.numeric(brts) == FALSE) { cat("The branching times should be numeric.\n") - out2 = data.frame(lambda = -1,mu = -1,K = -1, loglik = -1, df = -1, conv = -1) - if(ddmodel == 5) {out2 = data.frame(lambda = -1,mu = -1,K = -1, r = -1, loglik = -1, df = -1, conv = -1)} + out2 <- output_error } else { idpars = sort(c(idparsopt,idparsfix)) - if((prod(idpars == (1:(3 + (ddmodel == 5)))) != 1) || (length(initparsopt) != length(idparsopt)) || (length(parsfix) != length(idparsfix))) + if (!all(idpars == (1:(3 + both_rates_vary))) || (length(initparsopt) != length(idparsopt)) || (length(parsfix) != length(idparsfix))) { cat("The parameters to be optimized and/or fixed are incoherent.\n") - out2 = data.frame(lambda = -1,mu = -1,K = -1, loglik = -1, df = -1, conv = -1) - if(ddmodel == 5) {out2 = data.frame(lambda = -1,mu = -1,K = -1, r = -1, loglik = -1, df = -1, conv = -1)} + out2 <- output_error } else { - namepars = c("lambda","mu","K") - if(ddmodel == 5) {namepars = namepars = c("lambda","mu","K","r")} + if(both_rates_vary) { + namepars = c("lambda","mu","K","r") + } else { + namepars = c("lambda","mu","K") + } if(length(namepars[idparsopt]) == 0) { optstr = "nothing" } else { optstr = namepars[idparsopt] } cat("You are optimizing",optstr,"\n") if(length(namepars[idparsfix]) == 0) { fixstr = "nothing" } else { fixstr = namepars[idparsfix] } @@ -191,8 +199,7 @@ dd_ML = function( if(initloglik == -Inf) { cat("The initial parameter values have a likelihood that is equal to 0 or below machine precision. Try again with different initial values.\n") - out2 = data.frame(lambda = -1,mu = -1,K = -1, loglik = -1, df = -1, conv = -1) - if(ddmodel == 5) {out2 = data.frame(lambda = -1,mu = -1,K = -1, r = -1, loglik = -1, df = -1, conv = -1)} + out2 <- output_error } else { #code up to DDD v1.6: out = optimx2(trparsopt,dd_loglik_choosepar,hess=NULL,method = "Nelder-Mead",hessian = FALSE,control = list(maximize = TRUE,abstol = pars2[8],reltol = pars2[7],trace = 0,starttests = FALSE,kkt = FALSE),trparsfix = trparsfix,idparsopt = idparsopt,idparsfix = idparsfix,brts = brts, pars2 = pars2,missnumspec = missnumspec) #out = dd_simplex(trparsopt,idparsopt,trparsfix,idparsfix,pars2,brts,missnumspec) @@ -200,30 +207,34 @@ dd_ML = function( if(out$conv != 0) { cat("Optimization has not converged. Try again with different initial values.\n") - out2 = data.frame(lambda = -1,mu = -1,K = -1, loglik = -1, df = -1, conv = unlist(out$conv)) - if(ddmodel == 5) {out2 = data.frame(lambda = -1,mu = -1,K = -1, r = -1, loglik = -1, df = -1, conv = unlist(out$conv))} + out2 <- output_error } else { MLtrpars = as.numeric(unlist(out$par)) MLpars = MLtrpars/(1-MLtrpars) - MLpars1 = rep(0,3) - if(ddmodel == 5) {MLpars1 = rep(0,4)} + if (both_rates_vary) { + MLpars1 <- rep(0,4) + } else { + MLpars1 <- rep(0,3) + } MLpars1[idparsopt] = MLpars if(length(idparsfix) != 0) { MLpars1[idparsfix] = parsfix } if(MLpars1[3] > 10^7){MLpars1[3] = Inf} ML = as.numeric(unlist(out$fvalues)) - out2 = data.frame(lambda = MLpars1[1],mu = MLpars1[2],K = MLpars1[3], loglik = ML, df = length(initparsopt), conv = unlist(out$conv)) - s1 = sprintf('Maximum likelihood parameter estimates: lambda: %f, mu: %f, K: %f',MLpars1[1],MLpars1[2],MLpars1[3]) - if(ddmodel == 5) - { - s1 = sprintf('%s, r: %f',s1,MLpars1[4]) - out2 = data.frame(lambda = MLpars1[1],mu = MLpars1[2],K = MLpars1[3], r = MLpars1[4], loglik = ML, df = length(initparsopt), conv = unlist(out$conv)) + if (both_rates_vary) { + s1 <- sprintf('Maximum likelihood parameter estimates: lambda: %f, mu: %f, K: %f, r: %f', MLpars1[1], MLpars1[2], MLpars1[3], MLpars1[4]) + out2 <- data.frame(lambda = MLpars1[1], mu = MLpars1[2], K = MLpars1[3], r = MLpars1[4], loglik = ML, df = length(initparsopt), conv = unlist(out$conv)) + } else { + s1 <- sprintf('Maximum likelihood parameter estimates: lambda: %f, mu: %f, K: %f', MLpars1[1], MLpars1[2], MLpars1[3]) + out2 <- data.frame(lambda = MLpars1[1], mu = MLpars1[2], K = MLpars1[3], loglik = ML, df = length(initparsopt), conv = unlist(out$conv)) + } + if(out2$conv != 0 & changeloglikifnoconv == T) { + out2$loglik = -Inf } - if(out2$conv != 0 & changeloglikifnoconv == T) { out2$loglik = -Inf } s2 = sprintf('Maximum loglikelihood: %f',ML) cat(paste("\n",s1,"\n",s2,"\n",sep = '')) } } } } - return(invisible(out2)) + return(invisible(out2)) } diff --git a/R/dd_loglik.R b/R/dd_loglik.R index fa2c6e4..4c57222 100644 --- a/R/dd_loglik.R +++ b/R/dd_loglik.R @@ -129,21 +129,21 @@ dd_loglik_test = function(pars1,pars2,brts,missnumspec,methode = 'analytical',rh #' @export dd_loglik dd_loglik = function(pars1,pars2,brts,missnumspec,methode = 'analytical') { - if(pars2[3] == 3) - { - rhs_func_name = 'dd_loglik_bw_rhs_FORTRAN' - } else - { - rhs_func_name = 'dd_loglik_rhs_FORTRAN' - } - if(methode == 'analytical') - { - out = dd_loglik2(pars1,pars2,brts,missnumspec) - } else - { - out = dd_loglik1(pars1,pars2,brts,missnumspec,methode = methode,rhs_func_name = rhs_func_name) - } - return(out) + if(pars2[3] == 3) + { + rhs_func_name = 'dd_loglik_bw_rhs_FORTRAN' + } else + { + rhs_func_name = 'dd_loglik_rhs_FORTRAN' + } + if(methode == 'analytical') + { + out = dd_loglik2(pars1,pars2,brts,missnumspec) + } else + { + out = dd_loglik1(pars1,pars2,brts,missnumspec,methode = methode,rhs_func_name = rhs_func_name) + } + return(out) } dd_loglik1 = function(pars1,pars2,brts,missnumspec,methode = 'lsoda',rhs_func_name = 'dd_loglik_rhs_FORTRAN') @@ -154,15 +154,22 @@ dd_loglik1 = function(pars1,pars2,brts,missnumspec,methode = 'lsoda',rhs_func_na pars2[6] = 2 } ddep = pars2[2] + both_rates_vary <- ddep %in% c(5:8, 11:13) cond = pars2[3] btorph = pars2[4] verbose = pars2[5] soc = pars2[6] - if(cond == 3) { soc = 2 } + if(cond == 3) { + soc = 2 + } la = pars1[1] mu = pars1[2] K = pars1[3] - if(ddep == 5) {r = pars1[4]} else {r = 0} + if(both_rates_vary) { + r = pars1[4] + } else { + r = 0 + } if(ddep == 1 | ddep == 5) { lx = min(max(1 + missnumspec,1 + ceiling(la/(la - mu) * (r + 1) * K)),ceiling(pars2[1])) @@ -309,146 +316,146 @@ dd_loglik1 = function(pars1,pars2,brts,missnumspec,methode = 'lsoda',rhs_func_na dd_loglik2 = function(pars1,pars2,brts,missnumspec) { -if(length(pars2) == 4) -{ + if(length(pars2) == 4) + { pars2[5] = 0 pars2[6] = 2 -} -ddep = pars2[2] -cond = pars2[3] -btorph = pars2[4] -verbose <- pars2[5] -soc = pars2[6] -if(cond == 3) -{ + } + ddep = pars2[2] + cond = pars2[3] + btorph = pars2[4] + verbose <- pars2[5] + soc = pars2[6] + if(cond == 3) + { soc = 2 -} -la = pars1[1] -mu = pars1[2] -K = pars1[3] -if(ddep == 5) -{ + } + la = pars1[1] + mu = pars1[2] + K = pars1[3] + if(ddep == 5) + { r = pars1[4] -} else -{ + } else + { r = 0 -} -if(ddep == 1 | ddep == 5) -{ + } + if(ddep == 1 | ddep == 5) + { lx = min(max(1 + missnumspec,1 + ceiling(la/(la - mu) * (r + 1) * K)),ceiling(pars2[1])) -} else if(ddep == 1.3) -{ + } else if(ddep == 1.3) + { lx = min(ceiling(K),ceiling(pars2[1])) -} else { + } else { lx = round(pars2[1]) -} -if((ddep == 1) & ((mu == 0 & missnumspec == 0 & floor(K) != ceiling(K) & la > 0.05) | K == Inf)) -{ + } + if((ddep == 1) & ((mu == 0 & missnumspec == 0 & floor(K) != ceiling(K) & la > 0.05) | K == Inf)) + { loglik = bd_loglik(pars1[1:(2 + (K < Inf))],c(2*(mu == 0 & K < Inf),pars2[3:6]),brts,missnumspec) -} else { -abstol = 1e-16 -reltol = 1e-10 -brts = -sort(abs(as.numeric(brts)),decreasing = TRUE) -if(sum(brts == 0) == 0) -{ - brts[length(brts) + 1] = 0 -} -S = length(brts) + (soc - 2) -if(min(pars1) < 0) -{ - loglik = -Inf -} else { -if((mu == 0 & (ddep == 2 | ddep == 2.1 | ddep == 2.2)) | (la == 0 & (ddep == 4 | ddep == 4.1 | ddep == 4.2)) | (la <= mu)) -{ - if(verbose) cat("These parameter values cannot satisfy lambda(N) = mu(N) for a positive and finite N.\n") - loglik = -Inf -} else { - if(((ddep == 1 | ddep == 5) & ceiling(la/(la - mu) * (r + 1) * K) < (S + missnumspec)) | ((ddep == 1.3) & ((S + missnumspec) > ceiling(K)))) + } else { + abstol = 1e-16 + reltol = 1e-10 + brts = -sort(abs(as.numeric(brts)),decreasing = TRUE) + if(sum(brts == 0) == 0) { - loglik = -Inf + brts[length(brts) + 1] = 0 + } + S = length(brts) + (soc - 2) + if(min(pars1) < 0) + { + loglik = -Inf } else { - loglik = (btorph == 0) * lgamma(S) - if(cond != 3) - { - probs = rep(0,lx) - probs[1] = 1 # change if other species at stem/crown age - for(k in 2:(S + 2 - soc)) - { - k1 = k + (soc - 2) - #y = deSolve::ode(probs,brts[(k-1):k],rhs_func,c(pars1,k1,ddep),rtol = reltol,atol = abstol,method = methode) - #probs2 = y[2,2:(lx+1)] - probs = dd_loglik_M(pars1,lx,k1,ddep,tt = abs(brts[k] - brts[k-1]),probs) - if(is.na(sum(probs)) && pars1[2]/pars1[1] < 1E-4 && missnumspec == 0) - { - loglik = dd_loglik_high_lambda(pars1 = pars1,pars2 = pars2,brts = brts) - if(verbose) cat('High lambda approximation has been applied.\n') - return(loglik) - } - if(k < (S + 2 - soc)) - { - #probs = flavec(ddep,la,mu,K,r,lx,k1) * probs # speciation event - probs = lambdamu(0:(lx - 1) + k1,c(pars1[1:3],r),ddep)[[1]] * probs - } - cp <- check_probs(loglik,probs,verbose); loglik <- cp[[1]]; probs<- cp[[2]]; - } - } else { - probs = rep(0,lx + 1) - probs[1 + missnumspec] = 1 - for(k in (S + 2 - soc):2) - { - k1 = k + (soc - 2) - #y = deSolve::ode(probs,-brts[k:(k-1)],dd_loglik_bw_rhs,c(pars1,k1,ddep),rtol = reltol,atol = abstol,method = methode) - #probs2 = y[2,2:(lx+2)] - probs = dd_loglik_M_bw(pars1,lx,k1,ddep,tt = abs(brts[k] - brts[k-1]),probs[1:lx]) - probs = c(probs,0) - if(k > soc) - { - #probs = c(flavec(ddep,la,mu,K,r,lx,k1-1),1) * probs # speciation event - probs = c(lambdamu(0:(lx - 1) + k1 - 1,pars1,ddep)[[1]],1) * probs - } - cp <- check_probs(loglik,probs[1:lx],verbose); loglik <- cp[[1]]; probs[1:lx] <- cp[[2]]; - } - } - if(probs[1 + (cond != 3) * missnumspec] <= 0 | loglik == -Inf) - { + if((mu == 0 & (ddep == 2 | ddep == 2.1 | ddep == 2.2)) | (la == 0 & (ddep == 4 | ddep == 4.1 | ddep == 4.2)) | (la <= mu)) + { + if(verbose) cat("These parameter values cannot satisfy lambda(N) = mu(N) for a positive and finite N.\n") + loglik = -Inf + } else { + if(((ddep == 1 | ddep == 5) & ceiling(la/(la - mu) * (r + 1) * K) < (S + missnumspec)) | ((ddep == 1.3) & ((S + missnumspec) > ceiling(K)))) + { loglik = -Inf - } else { - loglik = loglik + (cond != 3 | soc == 1) * log(probs[1 + (cond != 3) * missnumspec]) - lgamma(S + missnumspec + 1) + lgamma(S + 1) + lgamma(missnumspec + 1) - - logliknorm = 0 - if(cond == 1 | cond == 2) + } else { + loglik = (btorph == 0) * lgamma(S) + if(cond != 3) { - probsn = rep(0,lx) - probsn[1] = 1 # change if other species at stem or crown age - k = soc - t1 = brts[1] - t2 = brts[S + 2 - soc] - #y = deSolve::ode(probsn,c(t1,t2),rhs_func,c(pars1,k,ddep),rtol = reltol,atol = abstol,method = methode); - #probsn = y[2,2:(lx+1)] - probsn = dd_loglik_M(pars1,lx,k,ddep,tt = abs(t2 - t1),probsn) - if(soc == 1) { aux = 1:lx } - if(soc == 2) { aux = (2:(lx+1)) * (3:(lx+2))/6 } - probsc = probsn/aux - if(cond == 1) { logliknorm = log(sum(probsc)) } - if(cond == 2) { logliknorm = log(probsc[S + missnumspec - soc + 1])} + probs = rep(0,lx) + probs[1] = 1 # change if other species at stem/crown age + for(k in 2:(S + 2 - soc)) + { + k1 = k + (soc - 2) + #y = deSolve::ode(probs,brts[(k-1):k],rhs_func,c(pars1,k1,ddep),rtol = reltol,atol = abstol,method = methode) + #probs2 = y[2,2:(lx+1)] + probs = dd_loglik_M(pars1,lx,k1,ddep,tt = abs(brts[k] - brts[k-1]),probs) + if(is.na(sum(probs)) && pars1[2]/pars1[1] < 1E-4 && missnumspec == 0) + { + loglik = dd_loglik_high_lambda(pars1 = pars1,pars2 = pars2,brts = brts) + if(verbose) cat('High lambda approximation has been applied.\n') + return(loglik) + } + if(k < (S + 2 - soc)) + { + #probs = flavec(ddep,la,mu,K,r,lx,k1) * probs # speciation event + probs = lambdamu(0:(lx - 1) + k1,c(pars1[1:3],r),ddep)[[1]] * probs + } + cp <- check_probs(loglik,probs,verbose); loglik <- cp[[1]]; probs<- cp[[2]]; + } + } else { + probs = rep(0,lx + 1) + probs[1 + missnumspec] = 1 + for(k in (S + 2 - soc):2) + { + k1 = k + (soc - 2) + #y = deSolve::ode(probs,-brts[k:(k-1)],dd_loglik_bw_rhs,c(pars1,k1,ddep),rtol = reltol,atol = abstol,method = methode) + #probs2 = y[2,2:(lx+2)] + probs = dd_loglik_M_bw(pars1,lx,k1,ddep,tt = abs(brts[k] - brts[k-1]),probs[1:lx]) + probs = c(probs,0) + if(k > soc) + { + #probs = c(flavec(ddep,la,mu,K,r,lx,k1-1),1) * probs # speciation event + probs = c(lambdamu(0:(lx - 1) + k1 - 1,pars1,ddep)[[1]],1) * probs + } + cp <- check_probs(loglik,probs[1:lx],verbose); loglik <- cp[[1]]; probs[1:lx] <- cp[[2]]; + } } - if(cond == 3) - { - #probsn = rep(0,lx + 1) - #probsn[S + missnumspec + 1] = 1 #/ (S + missnumspec) - #TT = max(1,1/abs(la - mu)) * 100000000 * max(abs(brts)) # make this more efficient later - #y = deSolve::ode(probsn,c(0,TT),dd_loglik_bw_rhs,c(pars1,0,ddep),rtol = reltol,atol = abstol,method = methode) - #logliknorm = log(y[2,lx + 2]) - probsn = rep(0,lx + 1) - probsn[2] = 1 - MM = dd_loglik_M_aux(pars1,lx + 1,k = 0,ddep) - MM = MM[-1,-1] - #probsn = SparseM::solve(-MM,probsn[2:(lx + 1)]) - MMinv = SparseM::solve(MM) - probsn = -MMinv %*% probsn[2:(lx + 1)] - logliknorm = log(probsn[S + missnumspec]) - if(soc == 2) - { + if(probs[1 + (cond != 3) * missnumspec] <= 0 | loglik == -Inf) + { + loglik = -Inf + } else { + loglik = loglik + (cond != 3 | soc == 1) * log(probs[1 + (cond != 3) * missnumspec]) - lgamma(S + missnumspec + 1) + lgamma(S + 1) + lgamma(missnumspec + 1) + + logliknorm = 0 + if(cond == 1 | cond == 2) + { + probsn = rep(0,lx) + probsn[1] = 1 # change if other species at stem or crown age + k = soc + t1 = brts[1] + t2 = brts[S + 2 - soc] + #y = deSolve::ode(probsn,c(t1,t2),rhs_func,c(pars1,k,ddep),rtol = reltol,atol = abstol,method = methode); + #probsn = y[2,2:(lx+1)] + probsn = dd_loglik_M(pars1,lx,k,ddep,tt = abs(t2 - t1),probsn) + if(soc == 1) { aux = 1:lx } + if(soc == 2) { aux = (2:(lx+1)) * (3:(lx+2))/6 } + probsc = probsn/aux + if(cond == 1) { logliknorm = log(sum(probsc)) } + if(cond == 2) { logliknorm = log(probsc[S + missnumspec - soc + 1])} + } + if(cond == 3) + { + #probsn = rep(0,lx + 1) + #probsn[S + missnumspec + 1] = 1 #/ (S + missnumspec) + #TT = max(1,1/abs(la - mu)) * 100000000 * max(abs(brts)) # make this more efficient later + #y = deSolve::ode(probsn,c(0,TT),dd_loglik_bw_rhs,c(pars1,0,ddep),rtol = reltol,atol = abstol,method = methode) + #logliknorm = log(y[2,lx + 2]) + probsn = rep(0,lx + 1) + probsn[2] = 1 + MM = dd_loglik_M_aux(pars1,lx + 1,k = 0,ddep) + MM = MM[-1,-1] + #probsn = SparseM::solve(-MM,probsn[2:(lx + 1)]) + MMinv = SparseM::solve(MM) + probsn = -MMinv %*% probsn[2:(lx + 1)] + logliknorm = log(probsn[S + missnumspec]) + if(soc == 2) + { #probsn = rep(0,lx + 1) #probsn[1:lx] = probs[1:lx] #probsn = c(flavec(ddep,la,mu,K,r,lx,1),1) * probsn # speciation event @@ -462,27 +469,27 @@ if((mu == 0 & (ddep == 2 | ddep == 2.1 | ddep == 2.2)) | (la == 0 & (ddep == 4 | #probsn2 = SparseM::solve(-MM,probsn2[1:lx]) probsn2 = -MMinv %*% probsn2[1:lx] logliknorm = logliknorm - log(probsn2[1]) - } + } + } + loglik = loglik - logliknorm } - loglik = loglik - logliknorm - } + } + }} + if(verbose) + { + s1 = sprintf('Parameters: %f %f %f',pars1[1],pars1[2],pars1[3]) + if(ddep == 5) {s1 = sprintf('%s %f',s1,pars1[4])} + s2 = sprintf(', Loglikelihood: %f',loglik) + cat(s1,s2,"\n",sep = "") + utils::flush.console() } -}} -if(verbose) -{ - s1 = sprintf('Parameters: %f %f %f',pars1[1],pars1[2],pars1[3]) - if(ddep == 5) {s1 = sprintf('%s %f',s1,pars1[4])} - s2 = sprintf(', Loglikelihood: %f',loglik) - cat(s1,s2,"\n",sep = "") - utils::flush.console() -} -} -loglik = as.numeric(loglik) -if(is.nan(loglik) | is.na(loglik) | loglik == Inf) -{ + } + loglik = as.numeric(loglik) + if(is.nan(loglik) | is.na(loglik) | loglik == Inf) + { loglik = -Inf -} -return(loglik) + } + return(loglik) } dd_int <- function(initprobs,tvec,rhs_func,pars,rtol,atol,method) @@ -535,13 +542,13 @@ dd_integrate <- function(initprobs,tvec,rhs_func,pars,rtol,atol,method) { y <- dd_ode_FORTRAN(initprobs,tvec,parsvec,atol,rtol,method) } else - if(rhs_func_name == 'dd_loglik_bw_rhs_FORTRAN') - { - y <- dd_ode_FORTRAN(initprobs,tvec,parsvec,atol,rtol,method,runmod = "dd_runmodbw") - } else - { - y <- deSolve::ode(initprobs,tvec,rhs_func,parsvec,rtol = rtol,atol = atol,method = method) - } + if(rhs_func_name == 'dd_loglik_bw_rhs_FORTRAN') + { + y <- dd_ode_FORTRAN(initprobs,tvec,parsvec,atol,rtol,method,runmod = "dd_runmodbw") + } else + { + y <- deSolve::ode(initprobs,tvec,rhs_func,parsvec,rtol = rtol,atol = atol,method = method) + } } return(y) } @@ -561,9 +568,9 @@ dd_ode_FORTRAN <- function( #dyn.load(paste("d:/data/ms/DDD/dd_loglik_rhs_FORTRAN", .Platform$dynlib.ext, sep = "")) N <- length(initprobs) probs <- deSolve::ode(y = initprobs, parms = c(N + 0.,parsvec[length(parsvec)] + 0.), rpar = parsvec[-length(parsvec)], - times = tvec, func = runmod, initfunc = "dd_initmod", - ynames = c("SV"), dimens = N + 2, nout = 1, outnames = c("Sum"), - dllname = "DDD",atol = atol, rtol = rtol, method = methode)[,1:(N + 1)] + times = tvec, func = runmod, initfunc = "dd_initmod", + ynames = c("SV"), dimens = N + 2, nout = 1, outnames = c("Sum"), + dllname = "DDD",atol = atol, rtol = rtol, method = methode)[,1:(N + 1)] #dyn.unload(paste("d:/data/ms/DDD/dd_loglik_rhs_FORTRAN", .Platform$dynlib.ext, sep = "")) return(probs) } diff --git a/R/dd_loglik_choosepar.R b/R/dd_loglik_choosepar.R index fdad519..c76942a 100644 --- a/R/dd_loglik_choosepar.R +++ b/R/dd_loglik_choosepar.R @@ -1,9 +1,10 @@ dd_loglik_choosepar = function(trparsopt,trparsfix,idparsopt,idparsfix,pars2,brts,missnumspec,methode) { - trpars1 = rep(0,3) - if(pars2[2] == 5) - { + both_rates_vary <- pars2[2] %in% c(5:8, 11:13) + if(both_rates_vary) { trpars1 = rep(0,4) + } else { + trpars1 = rep(0,3) } trpars1[idparsopt] = trparsopt if(length(idparsfix) != 0) From 18299521d6b49bd0e0ab1dfd9c16faca5b012d16 Mon Sep 17 00:00:00 2001 From: Theo Pannetier Date: Tue, 30 Mar 2021 09:15:49 +0200 Subject: [PATCH 02/49] clearer conditions --- R/dd_ML.R | 10 +++++----- R/dd_loglik.R | 50 ++++++++++++++++++++++++++------------------------ 2 files changed, 31 insertions(+), 29 deletions(-) diff --git a/R/dd_ML.R b/R/dd_ML.R index da72a62..347c485 100644 --- a/R/dd_ML.R +++ b/R/dd_ML.R @@ -187,10 +187,10 @@ dd_ML = function( cat("You are fixing",fixstr,"\n") cat("Optimizing the likelihood - this may take a while.","\n") utils::flush.console() - trparsopt = initparsopt/(1 + initparsopt) - trparsopt[which(initparsopt == Inf)] = 1 - trparsfix = parsfix/(1 + parsfix) - trparsfix[which(parsfix == Inf)] = 1 + trparsopt = initparsopt / (1 + initparsopt) + trparsopt[which(initparsopt == Inf)] <- 1 # fix NaN + trparsfix = parsfix / (1 + parsfix) + trparsfix[which(parsfix == Inf)] <- 1 # fix NaN pars2 = c(res,ddmodel,cond,btorph,verbose,soc,tol,maxiter) optimpars = c(tol,maxiter) initloglik = dd_loglik_choosepar(trparsopt = trparsopt,trparsfix = trparsfix,idparsopt = idparsopt,idparsfix = idparsfix,pars2 = pars2,brts = brts,missnumspec = missnumspec, methode = methode) @@ -210,7 +210,7 @@ dd_ML = function( out2 <- output_error } else { MLtrpars = as.numeric(unlist(out$par)) - MLpars = MLtrpars/(1-MLtrpars) + MLpars = MLtrpars / (1 - MLtrpars) if (both_rates_vary) { MLpars1 <- rep(0,4) } else { diff --git a/R/dd_loglik.R b/R/dd_loglik.R index 4c57222..7d65003 100644 --- a/R/dd_loglik.R +++ b/R/dd_loglik.R @@ -155,6 +155,7 @@ dd_loglik1 = function(pars1,pars2,brts,missnumspec,methode = 'lsoda',rhs_func_na } ddep = pars2[2] both_rates_vary <- ddep %in% c(5:8, 11:13) + is_speciation_linear <- ddep %in% c(1, 1.3, 5, 6, 11) cond = pars2[3] btorph = pars2[4] verbose = pars2[5] @@ -165,22 +166,19 @@ dd_loglik1 = function(pars1,pars2,brts,missnumspec,methode = 'lsoda',rhs_func_na la = pars1[1] mu = pars1[2] K = pars1[3] - if(both_rates_vary) { - r = pars1[4] - } else { - r = 0 - } - if(ddep == 1 | ddep == 5) - { - lx = min(max(1 + missnumspec,1 + ceiling(la/(la - mu) * (r + 1) * K)),ceiling(pars2[1])) - } else { - if(ddep == 1.3) - { - lx = min(ceiling(K),ceiling(pars2[1])) + r <- ifelse(both_rates_vary, pars1[4], 0) + if (is_speciation_linear) { + if (ddep == 1.3) { + Kprime <- ceiling(K) } else { - lx = round(pars2[1]) + Kprime <- ceiling(la / (la - mu) * (r + 1) * K) + } else { + Kprime <- Inf } } + + lx = min(max(1 + missnumspec,1 + Kprime), ceiling(pars2[1])) + if((ddep == 1) & ((mu == 0 & missnumspec == 0 & floor(K) != ceiling(K) & la > 0.05) | K == Inf)) { loglik = bd_loglik(pars1[1:(2 + (K < Inf))],c(2*(mu == 0 & K < Inf),pars2[3:6]),brts,missnumspec) @@ -188,8 +186,7 @@ dd_loglik1 = function(pars1,pars2,brts,missnumspec,methode = 'lsoda',rhs_func_na abstol = 1e-16 reltol = 1e-10 brts = -sort(abs(as.numeric(brts)),decreasing = TRUE) - if(sum(brts == 0) == 0) - { + if (sum(brts == 0) == 0) { brts[length(brts) + 1] = 0 } S = length(brts) + (soc - 2) @@ -203,25 +200,30 @@ dd_loglik1 = function(pars1,pars2,brts,missnumspec,methode = 'lsoda',rhs_func_na if(verbose) cat("These parameter values cannot satisfy lambda(N) = mu(N) for a positive and finite N.\n") loglik = -Inf } else { - if(((ddep == 1 | ddep == 5) & ceiling(la/(la - mu) * (r + 1) * K) < (S + missnumspec)) | ((ddep == 1.3) & (S + missnumspec > ceiling(K)))) - { + if (is_speciation_linear && Kprime < missnumspec + S) { if(verbose) cat('The parameters are incompatible.\n') loglik = -Inf } else { loglik = (btorph == 0) * lgamma(S) - if(cond != 3) - { + if (cond != 3) { probs = rep(0,lx) probs[1] = 1 # change if other species at stem/crown age for(k in 2:(S + 2 - soc)) { k1 = k + (soc - 2) - y = dd_integrate(probs,brts[(k-1):k],rhs_func_name,c(pars1,k1,ddep),rtol = reltol,atol = abstol,method = methode) + y <- dd_integrate( + initprobs = probs, + tvec = brts[(k-1):k], + rhs_func = rhs_func_name, + pars = c(pars1,k1,ddep), + rtol = reltol, + atol = abstol, + method = methode + ) probs = y[2,2:(lx+1)] - if(is.na(sum(probs)) && pars1[2]/pars1[1] < 1E-4 && missnumspec == 0) - { - loglik = dd_loglik_high_lambda(pars1 = pars1,pars2 = pars2,brts = brts) - if(verbose) cat('High lambda approximation has been applied.\n') + if (any(is.na(probs)) && pars1[2] / pars1[1] < 1E-4 && missnumspec == 0) { + loglik = dd_loglik_high_lambda(pars1 = pars1, pars2 = pars2, brts = brts) + if (verbose) cat('High lambda approximation has been applied.\n') return(loglik) } if(k < (S + 2 - soc)) From 2011aa6f74b99d104ad315d326022c64932a3086 Mon Sep 17 00:00:00 2001 From: Theo Pannetier Date: Tue, 30 Mar 2021 09:42:55 +0200 Subject: [PATCH 03/49] fix condition L176 + indent conditions --- R/dd_loglik.R | 43 ++++++++++++++++--------------------------- 1 file changed, 16 insertions(+), 27 deletions(-) diff --git a/R/dd_loglik.R b/R/dd_loglik.R index 7d65003..0f9262c 100644 --- a/R/dd_loglik.R +++ b/R/dd_loglik.R @@ -172,9 +172,9 @@ dd_loglik1 = function(pars1,pars2,brts,missnumspec,methode = 'lsoda',rhs_func_na Kprime <- ceiling(K) } else { Kprime <- ceiling(la / (la - mu) * (r + 1) * K) - } else { - Kprime <- Inf - } + } + } else { + Kprime <- Inf } lx = min(max(1 + missnumspec,1 + Kprime), ceiling(pars2[1])) @@ -226,8 +226,7 @@ dd_loglik1 = function(pars1,pars2,brts,missnumspec,methode = 'lsoda',rhs_func_na if (verbose) cat('High lambda approximation has been applied.\n') return(loglik) } - if(k < (S + 2 - soc)) - { + if (k < (S + 2 - soc)) { probs = flavec(ddep,la,mu,K,r,lx,k1) * probs # speciation event } cp <- check_probs(loglik,probs,verbose); loglik <- cp[[1]]; probs <- cp[[2]]; @@ -513,8 +512,7 @@ dd_int <- function(initprobs,tvec,rhs_func,pars,rtol,atol,method) dd_integrate <- function(initprobs,tvec,rhs_func,pars,rtol,atol,method) { - if(method == 'analytical') - { + if(method == 'analytical') { probs <- dd_loglik_M(pars = pars[1:3], lx = length(initprobs), k = pars[4], @@ -522,35 +520,26 @@ dd_integrate <- function(initprobs,tvec,rhs_func,pars,rtol,atol,method) tt = abs(tvec[2] - tvec[1]), initprobs) y <- cbind(c(NA,NA),rbind(rep(NA,length(probs)),probs)) - } else - { + } else { rhs_func_name <- 'no_name' - if(is.character(rhs_func)) - { + if (is.character(rhs_func)) { rhs_func_name <- rhs_func - if(rhs_func_name != 'dd_loglik_rhs_FORTRAN' & rhs_func_name != 'dd_loglik_bw_rhs_FORTRAN') - { + if(rhs_func_name != 'dd_loglik_rhs_FORTRAN' & rhs_func_name != 'dd_loglik_bw_rhs_FORTRAN') { rhs_func = match.fun(rhs_func) } } - if(rhs_func_name == 'dd_loglik_rhs' || rhs_func_name == 'dd_loglik_bw_rhs' || rhs_func_name == 'dd_loglik_rhs_FORTRAN' || rhs_func_name == 'dd_loglik_bw_rhs_FORTRAN') - { + if (rhs_func_name == 'dd_loglik_rhs' || rhs_func_name == 'dd_loglik_bw_rhs' || rhs_func_name == 'dd_loglik_rhs_FORTRAN' || rhs_func_name == 'dd_loglik_bw_rhs_FORTRAN') { parsvec = c(dd_loglik_rhs_precomp(pars,initprobs),pars[length(pars) - 1]) - } else - { + } else { parsvec = pars } - if(rhs_func_name == 'dd_loglik_rhs_FORTRAN') - { + if (rhs_func_name == 'dd_loglik_rhs_FORTRAN') { y <- dd_ode_FORTRAN(initprobs,tvec,parsvec,atol,rtol,method) - } else - if(rhs_func_name == 'dd_loglik_bw_rhs_FORTRAN') - { - y <- dd_ode_FORTRAN(initprobs,tvec,parsvec,atol,rtol,method,runmod = "dd_runmodbw") - } else - { - y <- deSolve::ode(initprobs,tvec,rhs_func,parsvec,rtol = rtol,atol = atol,method = method) - } + } else if (rhs_func_name == 'dd_loglik_bw_rhs_FORTRAN') { + y <- dd_ode_FORTRAN(initprobs,tvec,parsvec,atol,rtol,method,runmod = "dd_runmodbw") + } else { + y <- deSolve::ode(initprobs,tvec,rhs_func,parsvec,rtol = rtol,atol = atol,method = method) + } } return(y) } From b1d4943b38ffe3d5ab5131f8b60adaf147499586 Mon Sep 17 00:00:00 2001 From: Theo Pannetier Date: Tue, 30 Mar 2021 09:53:15 +0200 Subject: [PATCH 04/49] simpler rep() syntax for dd_loglik_rhs_precomp --- R/dd_loglik_rhs.R | 68 +++++++++++++++++++++-------------------------- 1 file changed, 30 insertions(+), 38 deletions(-) diff --git a/R/dd_loglik_rhs.R b/R/dd_loglik_rhs.R index b6b080b..26b2b1f 100644 --- a/R/dd_loglik_rhs.R +++ b/R/dd_loglik_rhs.R @@ -15,56 +15,48 @@ dd_loglik_rhs_precomp = function(pars,x) } n0 = (ddep == 2 | ddep == 4) - nn = -1:(lx+2*kk) - lnn = length(nn) - nn = pmax(rep(0,lnn),nn) - - if(ddep == 1) - { - lavec = pmax(rep(0,lnn),la - (la - mu)/K * nn) - muvec = mu * rep(1,lnn) + nn <- c(0, 0:(lx + 2 * kk)) + lnn <- length(nn) + + if(ddep == 1) { + lavec = pmax(0, la - (la - mu) / K * nn) + muvec = rep(mu, lnn) } else { - if(ddep == 1.3) - { - lavec = pmax(rep(0,lnn),la * (1 - nn/K)) - muvec = mu * rep(1,lnn) + if (ddep == 1.3) { + lavec = pmax(0, la * (1 - nn / K)) + muvec = rep(mu, lnn) } else { - if(ddep == 1.4) - { - lavec = pmax(rep(0,lnn),la * nn/(nn + K)) + if (ddep == 1.4) { + lavec = pmax(0, la * nn / (nn + K)) } else { if(ddep == 1.5) { - lavec = pmax(rep(0,lnn),la * nn/K * (1 - nn/K)) - muvec = mu * rep(1,lnn) + lavec = pmax(0, la * nn / K * (1 - nn / K)) + muvec = rep(mu, lnn) } else { - if(ddep == 2 | ddep == 2.1 | ddep == 2.2) - { - y = -(log(la/mu)/log(K+n0))^(ddep != 2.2) - lavec = pmax(rep(0,lnn),la * (nn + n0)^y) - muvec = mu * rep(1,lnn) + if (ddep == 2 | ddep == 2.1 | ddep == 2.2) { + y = -(log(la / mu) / log(K + n0)) ^ (ddep != 2.2) + lavec = pmax(0, la * (nn + n0) ^ y) + muvec = rep(mu, lnn) } else { if(ddep == 2.3) { y = -K - lavec = pmax(rep(0,lnn),la * (nn + n0)^y) - muvec = mu * rep(1,lnn) + lavec = pmax(0, la * (nn + n0) ^ y) + muvec = rep(mu, lnn) } else { - if(ddep == 3) - { - lavec = la * rep(1,lnn) - muvec = mu + (la - mu) * nn/K + if (ddep == 3) { + lavec = rep(la, lnn) + muvec = mu + (la - mu) * nn / K } else { - if(ddep == 4 | ddep == 4.1 | ddep == 4.2) - { - lavec = la * rep(1,lnn) - y = (log(la/mu)/log(K+n0))^(ddep != 4.2) - muvec = mu * (nn + n0)^y + if (ddep == 4 | ddep == 4.1 | ddep == 4.2) { + lavec = rep(la, lnn) + y = (log(la / mu) / log(K + n0)) ^ (ddep != 4.2) + muvec = mu * (nn + n0) ^ y } else { - if(ddep == 5) - { - lavec = pmax(rep(0,lnn),la - 1/(r + 1)*(la - mu)/K * nn) - muvec = muvec = mu + r/(r + 1)*(la - mu)/K * nn + if (ddep == 5) { + lavec = pmax(0, la - 1 / (r + 1) * (la - mu) / K * nn) + muvec = mu + r / (r + 1) * (la - mu) / K * nn } } } @@ -74,7 +66,7 @@ dd_loglik_rhs_precomp = function(pars,x) } } } - return(c(lavec,muvec,nn)) + return(c(lavec, muvec, nn)) } dd_loglik_rhs = function(t,x,parsvec) From 81506c489d8a6966882d9ec74303d52eaf0f38e7 Mon Sep 17 00:00:00 2001 From: Theo Pannetier Date: Tue, 30 Mar 2021 09:56:47 +0200 Subject: [PATCH 05/49] unnested if statements --- R/dd_loglik_rhs.R | 77 ++++++++++++++++++----------------------------- 1 file changed, 29 insertions(+), 48 deletions(-) diff --git a/R/dd_loglik_rhs.R b/R/dd_loglik_rhs.R index 26b2b1f..3c9dfe8 100644 --- a/R/dd_loglik_rhs.R +++ b/R/dd_loglik_rhs.R @@ -4,8 +4,7 @@ dd_loglik_rhs_precomp = function(pars,x) la = pars[1] mu = pars[2] K = pars[3] - if(length(pars) < 6) - { + if (length(pars) < 6) { kk = pars[4] ddep = pars[5] } else { @@ -17,54 +16,36 @@ dd_loglik_rhs_precomp = function(pars,x) nn <- c(0, 0:(lx + 2 * kk)) lnn <- length(nn) - - if(ddep == 1) { + + if (ddep == 1) { lavec = pmax(0, la - (la - mu) / K * nn) muvec = rep(mu, lnn) - } else { - if (ddep == 1.3) { - lavec = pmax(0, la * (1 - nn / K)) - muvec = rep(mu, lnn) - } else { - if (ddep == 1.4) { - lavec = pmax(0, la * nn / (nn + K)) - } else { - if(ddep == 1.5) - { - lavec = pmax(0, la * nn / K * (1 - nn / K)) - muvec = rep(mu, lnn) - } else { - if (ddep == 2 | ddep == 2.1 | ddep == 2.2) { - y = -(log(la / mu) / log(K + n0)) ^ (ddep != 2.2) - lavec = pmax(0, la * (nn + n0) ^ y) - muvec = rep(mu, lnn) - } else { - if(ddep == 2.3) - { - y = -K - lavec = pmax(0, la * (nn + n0) ^ y) - muvec = rep(mu, lnn) - } else { - if (ddep == 3) { - lavec = rep(la, lnn) - muvec = mu + (la - mu) * nn / K - } else { - if (ddep == 4 | ddep == 4.1 | ddep == 4.2) { - lavec = rep(la, lnn) - y = (log(la / mu) / log(K + n0)) ^ (ddep != 4.2) - muvec = mu * (nn + n0) ^ y - } else { - if (ddep == 5) { - lavec = pmax(0, la - 1 / (r + 1) * (la - mu) / K * nn) - muvec = mu + r / (r + 1) * (la - mu) / K * nn - } - } - } - } - } - } - } - } + } else if (ddep == 1.3) { + lavec = pmax(0, la * (1 - nn / K)) + muvec = rep(mu, lnn) + } else if (ddep == 1.4) { + lavec = pmax(0, la * nn / (nn + K)) + } else if(ddep == 1.5) { + lavec = pmax(0, la * nn / K * (1 - nn / K)) + muvec = rep(mu, lnn) + } else if (ddep == 2 | ddep == 2.1 | ddep == 2.2) { + y = -(log(la / mu) / log(K + n0)) ^ (ddep != 2.2) + lavec = pmax(0, la * (nn + n0) ^ y) + muvec = rep(mu, lnn) + } else if(ddep == 2.3) { + y = -K + lavec = pmax(0, la * (nn + n0) ^ y) + muvec = rep(mu, lnn) + } else if (ddep == 3) { + lavec = rep(la, lnn) + muvec = mu + (la - mu) * nn / K + } else if (ddep == 4 | ddep == 4.1 | ddep == 4.2) { + lavec = rep(la, lnn) + y = (log(la / mu) / log(K + n0)) ^ (ddep != 4.2) + muvec = mu * (nn + n0) ^ y + } else if (ddep == 5) { + lavec = pmax(0, la - 1 / (r + 1) * (la - mu) / K * nn) + muvec = mu + r / (r + 1) * (la - mu) / K * nn } return(c(lavec, muvec, nn)) } From 62ac486e60bb5d6e0d5e8a1ed52dfe3d1b9b712c Mon Sep 17 00:00:00 2001 From: Theo Pannetier Date: Tue, 30 Mar 2021 11:21:42 +0200 Subject: [PATCH 06/49] implemented new DD models in dd_loglik_rhs_precomp --- R/dd_loglik_rhs.R | 28 ++++++++++++++++++++++++++++ 1 file changed, 28 insertions(+) diff --git a/R/dd_loglik_rhs.R b/R/dd_loglik_rhs.R index 3c9dfe8..cb74de6 100644 --- a/R/dd_loglik_rhs.R +++ b/R/dd_loglik_rhs.R @@ -46,6 +46,34 @@ dd_loglik_rhs_precomp = function(pars,x) } else if (ddep == 5) { lavec = pmax(0, la - 1 / (r + 1) * (la - mu) / K * nn) muvec = mu + r / (r + 1) * (la - mu) / K * nn + } else if (ddep == 6) { + y = log((la * r + mu) / (mu * (1 + r))) / log(K) + lavec = pmax(0, la - 1 / (r + 1) * (la - mu) / K * nn) + muvec = mu * nn ^ y + } else if (ddep == 7) { + y1 = -log(la * (1 + r) / (la * r + mu)) / log(K) + y2 = log((la * r + mu) / (mu * (1 + r))) / log(K) + lavec = pmax(0, la * nn ^ y1) + muvec = mu * nn ^ y2 + } else if (ddep == 8) { + y = -log(la * (1 + r) / (la * r + mu)) / log(K) + lavec = pmax(0, la * nn ^ y) + muvec = mu + r / (r + 1) * (la - mu) / K * nn + } else if (ddep == 9) { + lavec = pmax(0, la * (mu / la) ^ (nn / K)) + muvec = rep(mu, lnn) + } else if (ddep == 10) { + lavec = rep(la, lnn) + muvec = mu * (la / mu) ^ (nn / K) + } else if (ddep == 11) { + lavec = pmax(0, la - 1 / (r + 1) * (la - mu) / K * nn) + muvec = mu * ((r * la + mu) / (mu * (1 + r))) ^ (nn / K) + } else if (ddep == 12) { + lavec = pmax(0, la * ((r * la + mu) / (la * (1 + r))) ^ (nn / K)) + muvec = mu * ((r * la + mu) / (mu * (1 + r))) ^ (nn / K) + } else if (ddep == 13) { + lavec = pmax(0, la * ((r * la + mu) / (la * (1 + r))) ^ (nn / K)) + muvec = mu + r / (r + 1) * (la - mu) / K * nn } return(c(lavec, muvec, nn)) } From 74710a13c4a33ac1050b64d37c3941c8c056293f Mon Sep 17 00:00:00 2001 From: Theo Pannetier Date: Sat, 3 Apr 2021 10:01:08 +0200 Subject: [PATCH 07/49] syntax a bit more readable --- R/dd_loglik.R | 51 ++++++++++++++++++++++++++++++++--------------- R/dd_loglik_rhs.R | 12 ++++++++--- R/dd_utils.R | 4 ++-- 3 files changed, 46 insertions(+), 21 deletions(-) diff --git a/R/dd_loglik.R b/R/dd_loglik.R index 0f9262c..23a29e3 100644 --- a/R/dd_loglik.R +++ b/R/dd_loglik.R @@ -206,13 +206,13 @@ dd_loglik1 = function(pars1,pars2,brts,missnumspec,methode = 'lsoda',rhs_func_na } else { loglik = (btorph == 0) * lgamma(S) if (cond != 3) { - probs = rep(0,lx) - probs[1] = 1 # change if other species at stem/crown age + qn_vec = rep(0,lx) + qn_vec[1] = 1 # change if other species at stem/crown age for(k in 2:(S + 2 - soc)) { k1 = k + (soc - 2) y <- dd_integrate( - initprobs = probs, + initprobs = qn_vec, tvec = brts[(k-1):k], rhs_func = rhs_func_name, pars = c(pars1,k1,ddep), @@ -220,38 +220,49 @@ dd_loglik1 = function(pars1,pars2,brts,missnumspec,methode = 'lsoda',rhs_func_na atol = abstol, method = methode ) - probs = y[2,2:(lx+1)] - if (any(is.na(probs)) && pars1[2] / pars1[1] < 1E-4 && missnumspec == 0) { + qn_vec = y[2,2:(lx+1)] + + if (any(is.na(qn_vec)) && pars1[2] / pars1[1] < 1E-4 && missnumspec == 0) { loglik = dd_loglik_high_lambda(pars1 = pars1, pars2 = pars2, brts = brts) if (verbose) cat('High lambda approximation has been applied.\n') return(loglik) } if (k < (S + 2 - soc)) { - probs = flavec(ddep,la,mu,K,r,lx,k1) * probs # speciation event + qn_vec <- flavec(ddep, la, mu, K, r, lx, k1) * qn_vec # speciation event } - cp <- check_probs(loglik,probs,verbose); loglik <- cp[[1]]; probs <- cp[[2]]; + cp <- check_probs(loglik, qn_vec, verbose) + loglik <- cp[[1]] + qn_vec <- cp[[2]] } } else { - probs = rep(0,lx + 1) - probs[1 + missnumspec] = 1 + qn_vec = rep(0,lx + 1) + qn_vec[1 + missnumspec] = 1 for(k in (S + 2 - soc):2) { k1 = k + (soc - 2) - y = dd_integrate(probs,-brts[k:(k-1)],rhs_func_name,c(pars1,k1,ddep),rtol = reltol,atol = abstol,method = methode) - probs = y[2,2:(lx+2)] + y = dd_integrate( + initprobs = qn_vec, + tvec = -brts[k:(k-1)], + rhs_func = rhs_func_name, + pars = c(pars1,k1,ddep), + rtol = reltol, + atol = abstol, + method = methode + ) + qn_vec = y[2,2:(lx+2)] if(k > soc) { - probs = c(flavec(ddep,la,mu,K,r,lx,k1-1),1) * probs # speciation event + qn_vec = c(flavec(ddep,la,mu,K,r,lx,k1-1),1) * qn_vec # speciation event } - cp <- check_probs(loglik,probs[1:lx],verbose); loglik <- cp[[1]]; probs[1:lx] <- cp[[2]]; + cp <- check_probs(loglik,qn_vec[1:lx],verbose); loglik <- cp[[1]]; qn_vec[1:lx] <- cp[[2]]; } } - if(probs[1 + missnumspec] <= 0 | loglik == -Inf | is.na(loglik) | is.nan(loglik)) + if(qn_vec[1 + missnumspec] <= 0 | loglik == -Inf | is.na(loglik) | is.nan(loglik)) { if(verbose) cat('Probabilities smaller than 0 or other numerical problems are encountered in final result.\n') loglik = -Inf } else { - loglik = loglik + (cond != 3 | soc == 1) * log(probs[1 + (cond != 3) * missnumspec]) - lgamma(S + missnumspec + 1) + lgamma(S + 1) + lgamma(missnumspec + 1) + loglik = loglik + (cond != 3 | soc == 1) * log(qn_vec[1 + (cond != 3) * missnumspec]) - lgamma(S + missnumspec + 1) + lgamma(S + 1) + lgamma(missnumspec + 1) logliknorm = 0 if(cond == 1 | cond == 2) @@ -538,7 +549,15 @@ dd_integrate <- function(initprobs,tvec,rhs_func,pars,rtol,atol,method) } else if (rhs_func_name == 'dd_loglik_bw_rhs_FORTRAN') { y <- dd_ode_FORTRAN(initprobs,tvec,parsvec,atol,rtol,method,runmod = "dd_runmodbw") } else { - y <- deSolve::ode(initprobs,tvec,rhs_func,parsvec,rtol = rtol,atol = atol,method = method) + y <- deSolve::ode( + y = initprobs, + times = tvec, + func = rhs_func, + parms = parsvec, + rtol = rtol, + atol = atol, + method = method + ) } } return(y) diff --git a/R/dd_loglik_rhs.R b/R/dd_loglik_rhs.R index cb74de6..f4f1bed 100644 --- a/R/dd_loglik_rhs.R +++ b/R/dd_loglik_rhs.R @@ -80,13 +80,19 @@ dd_loglik_rhs_precomp = function(pars,x) dd_loglik_rhs = function(t,x,parsvec) { + # Unpack parameter vector lv = (length(parsvec) - 1)/3 lavec = parsvec[1:lv] muvec = parsvec[(lv + 1):(2 * lv)] nn = parsvec[(2 * lv + 1):(3 * lv)] - kk = parsvec[length(parsvec)] + k = parsvec[length(parsvec)] # nb species in phylo at time t + lx = length(x) - xx = c(0,x,0) - dx = lavec[(2:(lx+1))+kk-1] * nn[(2:(lx+1))+2*kk-1] * xx[(2:(lx+1))-1] + muvec[(2:(lx+1))+kk+1] * nn[(2:(lx+1))+1] * xx[(2:(lx+1))+1] - (lavec[(2:(lx+1))+kk] + muvec[(2:(lx+1))+kk]) * nn[(2:(lx+1))+kk] * xx[2:(lx+1)] + qn_vec = c(0, x, 0) + nvec <- 2:(lx + 1) + # DDD master system + dx <- lavec[nvec + k - 1] * nn[nvec + 2 * k - 1] * qn_vec[nvec - 1] + + muvec[nvec + k + 1] * nn[nvec + 1] * qn_vec[nvec + 1] - + (lavec[nvec + k] + muvec[nvec + k]) * nn[nvec + k] * qn_vec[nvec] return(list(dx)) } \ No newline at end of file diff --git a/R/dd_utils.R b/R/dd_utils.R index a2e8dae..56eca4e 100644 --- a/R/dd_utils.R +++ b/R/dd_utils.R @@ -111,8 +111,8 @@ conv = function(x,y) flavec <- function(ddep,la,mu,K,r,lx,kk) { nn <- (0:(lx - 1)) + kk - lambdamu_nk <- lambdamu(nn,c(la,mu,K,r),ddep) - return(lambdamu_nk[[1]]) + lambda_n_vec <- lambdamu(nn, c(la, mu, K, r), ddep)[[1]] + return(lambda_n_vec) } flavec2 = function(ddep,la,mu,K,r,lx,kk,n0) From a90eb6c12d985f4240b9cd2267d338beb30ced21 Mon Sep 17 00:00:00 2001 From: Theo Pannetier Date: Sat, 3 Apr 2021 10:02:08 +0200 Subject: [PATCH 08/49] new DD functions implemented in lambdamu --- R/dd_loglik_M.R | 70 +++++++++++++++++++++++++++++++++---------------- 1 file changed, 48 insertions(+), 22 deletions(-) diff --git a/R/dd_loglik_M.R b/R/dd_loglik_M.R index d295ce1..bd05e87 100644 --- a/R/dd_loglik_M.R +++ b/R/dd_loglik_M.R @@ -1,41 +1,67 @@ lambdamu = function(n,pars,ddep) { lnn = length(n) - zeros = rep(0,lnn) - ones = rep(1,lnn) la = pars[1] mu = pars[2] K = pars[3] r = pars[4] - lavec = la * ones - muvec = mu * ones n0 = (ddep == 2 | ddep == 4) - if(ddep == 1) - { - lavec = pmax(zeros,la - (la - mu) * n / K) - } else if(ddep == 1.3) - { - lavec = pmax(zeros,la * (1 - n/K)) - } else if(ddep == 2 | ddep == 2.1 | ddep == 2.2) - { - y = -(log(la/mu)/log(K+n0))^(ddep != 2.2) - lavec = pmax(zeros,la * (n + n0)^y) + if(ddep == 1) { + lavec = pmax(0, la - (la - mu) * n / K) + muvec = rep(mu, lnn) + } else if(ddep == 1.3) { + lavec = pmax(0, la * (1 - n / K)) + muvec = rep(mu, lnn) + } else if(ddep == 2 | ddep == 2.1 | ddep == 2.2) { + y = -(log(la / mu) / log(K + n0)) ^ (ddep != 2.2) + lavec = pmax(0, la * (n + n0) ^ y) + muvec = rep(mu, lnn) } else if(ddep == 2.3) { y = -K - lavec = pmax(zeros,la * (n + n0)^y) + lavec = pmax(0, la * (n + n0) ^ y) + muvec = rep(mu, lnn) } else if(ddep == 3) { - lavec = la * ones + lavec = rep(la, lnn) muvec = mu + (la - mu) * n/K - } else if(ddep == 4 | ddep == 4.1 | ddep == 4.2) + } else if (ddep == 4 | ddep == 4.1 | ddep == 4.2) { - y = (log(la/mu)/log(K+n0))^(ddep != 4.2) - muvec = mu * (n + n0)^y - } else if(ddep == 5) + y = (log(la / mu) / log(K + n0)) ^ (ddep != 4.2) + lavec = rep(la, lnn) + muvec = mu * (n + n0) ^ y + } else if (ddep == 5) { - lavec = pmax(zeros,la - 1/(r + 1)*(la - mu)/K * n) - muvec = muvec = mu + r/(r + 1)*(la - mu)/K * n + lavec = pmax(0, la - 1 / (r + 1) * (la - mu) / K * n) + muvec = muvec = mu + r / (r + 1) * (la - mu) / K * n + } else if (ddep == 6) { + y = log((la * r + mu) / (mu * (1 + r))) / log(K) + lavec = pmax(0, la - 1 / (r + 1) * (la - mu) / K * n) + muvec = mu * n ^ y + } else if (ddep == 7) { + y1 = -log(la * (1 + r) / (la * r + mu)) / log(K) + y2 = log((la * r + mu) / (mu * (1 + r))) / log(K) + lavec = pmax(0, la * n ^ y1) + muvec = mu * n ^ y2 + } else if (ddep == 8) { + y = -log(la * (1 + r) / (la * r + mu)) / log(K) + lavec = pmax(0, la * n ^ y) + muvec = mu + r / (r + 1) * (la - mu) / K * n + } else if (ddep == 9) { + lavec = pmax(0, la * (mu / la) ^ (n / K)) + muvec = rep(mu, lnn) + } else if (ddep == 10) { + lavec = rep(la, lnn) + muvec = mu * (la / mu) ^ (n / K) + } else if (ddep == 11) { + lavec = pmax(0, la - 1 / (r + 1) * (la - mu) / K * n) + muvec = mu * ((r * la + mu) / (mu * (1 + r))) ^ (n / K) + } else if (ddep == 12) { + lavec = pmax(0, la * ((r * la + mu) / (la * (1 + r))) ^ (n / K)) + muvec = mu * ((r * la + mu) / (mu * (1 + r))) ^ (n / K) + } else if (ddep == 13) { + lavec = pmax(0, la * ((r * la + mu) / (la * (1 + r))) ^ (n / K)) + muvec = mu + r / (r + 1) * (la - mu) / K * n } return(list(lavec,muvec)) } From 4632d42ca7b006974c425eac442b83186b972b2c Mon Sep 17 00:00:00 2001 From: Theo Pannetier Date: Sat, 3 Apr 2021 11:43:54 +0200 Subject: [PATCH 09/49] fix missed variable renaming --- R/dd_loglik.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/R/dd_loglik.R b/R/dd_loglik.R index 23a29e3..4d03156 100644 --- a/R/dd_loglik.R +++ b/R/dd_loglik.R @@ -228,7 +228,7 @@ dd_loglik1 = function(pars1,pars2,brts,missnumspec,methode = 'lsoda',rhs_func_na return(loglik) } if (k < (S + 2 - soc)) { - qn_vec <- flavec(ddep, la, mu, K, r, lx, k1) * qn_vec # speciation event + qn_vec <- flavec(ddep, la, mu, K, r, lx, k1) * qn_vec # transition vector } cp <- check_probs(loglik, qn_vec, verbose) loglik <- cp[[1]] @@ -291,7 +291,7 @@ dd_loglik1 = function(pars1,pars2,brts,missnumspec,methode = 'lsoda',rhs_func_na if(soc == 2) { probsn = rep(0,lx + 1) - probsn[1:lx] = probs[1:lx] + probsn[1:lx] = qn_vec[1:lx] probsn = c(flavec(ddep,la,mu,K,r,lx,1),1) * probsn # speciation event y = dd_integrate(probsn,c(max(abs(brts)),TT),rhs_func_name,c(pars1,1,ddep),rtol = reltol,atol = abstol,method = methode) logliknorm = logliknorm - log(y[2,lx + 2]) From e038856207bc4adcb1ac3f345917452d4bdeb097 Mon Sep 17 00:00:00 2001 From: Theo Pannetier Date: Sat, 3 Apr 2021 12:02:36 +0200 Subject: [PATCH 10/49] more indentation/spacing fixes --- R/dd_loglik.R | 100 ++++++++++++++++++++++++++++++++------------------ R/dd_utils.R | 10 ++--- 2 files changed, 69 insertions(+), 41 deletions(-) diff --git a/R/dd_loglik.R b/R/dd_loglik.R index 4d03156..6781f97 100644 --- a/R/dd_loglik.R +++ b/R/dd_loglik.R @@ -201,15 +201,14 @@ dd_loglik1 = function(pars1,pars2,brts,missnumspec,methode = 'lsoda',rhs_func_na loglik = -Inf } else { if (is_speciation_linear && Kprime < missnumspec + S) { - if(verbose) cat('The parameters are incompatible.\n') + if (verbose) cat('The parameters are incompatible.\n') loglik = -Inf } else { loglik = (btorph == 0) * lgamma(S) if (cond != 3) { qn_vec = rep(0,lx) qn_vec[1] = 1 # change if other species at stem/crown age - for(k in 2:(S + 2 - soc)) - { + for (k in 2:(S + 2 - soc)) { k1 = k + (soc - 2) y <- dd_integrate( initprobs = qn_vec, @@ -220,7 +219,7 @@ dd_loglik1 = function(pars1,pars2,brts,missnumspec,methode = 'lsoda',rhs_func_na atol = abstol, method = methode ) - qn_vec = y[2,2:(lx+1)] + qn_vec = y[2, 2:(lx+1)] if (any(is.na(qn_vec)) && pars1[2] / pars1[1] < 1E-4 && missnumspec == 0) { loglik = dd_loglik_high_lambda(pars1 = pars1, pars2 = pars2, brts = brts) @@ -254,73 +253,104 @@ dd_loglik1 = function(pars1,pars2,brts,missnumspec,methode = 'lsoda',rhs_func_na { qn_vec = c(flavec(ddep,la,mu,K,r,lx,k1-1),1) * qn_vec # speciation event } - cp <- check_probs(loglik,qn_vec[1:lx],verbose); loglik <- cp[[1]]; qn_vec[1:lx] <- cp[[2]]; + cp <- check_probs(loglik,qn_vec[1:lx],verbose) + loglik <- cp[[1]] + qn_vec[1:lx] <- cp[[2]] } } if(qn_vec[1 + missnumspec] <= 0 | loglik == -Inf | is.na(loglik) | is.nan(loglik)) { if(verbose) cat('Probabilities smaller than 0 or other numerical problems are encountered in final result.\n') loglik = -Inf - } else { + } else { loglik = loglik + (cond != 3 | soc == 1) * log(qn_vec[1 + (cond != 3) * missnumspec]) - lgamma(S + missnumspec + 1) + lgamma(S + 1) + lgamma(missnumspec + 1) logliknorm = 0 - if(cond == 1 | cond == 2) - { - probsn = rep(0,lx) + if(cond == 1 | cond == 2) { + probsn = rep(0, lx) probsn[1] = 1 # change if other species at stem or crown age k = soc t1 = brts[1] t2 = brts[S + 2 - soc] - y = dd_integrate(probsn,c(t1,t2),rhs_func_name,c(pars1,k,ddep),rtol = reltol,atol = abstol,method = methode); - probsn = y[2,2:(lx+1)] - if(soc == 1) { aux = 1:lx } - if(soc == 2) { aux = (2:(lx+1)) * (3:(lx+2))/6 } - probsc = probsn/aux - cp <- check_probs(logliknorm,probsc,verbose); logliknorm <- cp[[1]]; probsc <- cp[[2]]; - if(cond == 1) { logliknorm = logliknorm + log(sum(probsc)) } - if(cond == 2) { logliknorm = logliknorm + log(probsc[S + missnumspec - soc + 1])} + y = dd_integrate( + initprobs = probsn, + tvec = c(t1,t2), + rhs_func = rhs_func_name, + pars = c(pars1,k,ddep), + rtol = reltol, + atol = abstol, + method = methode + ) + probsn = y[2, 2:(lx + 1)] + if(soc == 1) { + aux = 1:lx + } + if(soc == 2) { + aux = (2:(lx + 1)) * (3:(lx + 2)) / 6 + } + probsc = probsn / aux + cp <- check_probs(logliknorm,probsc,verbose) + logliknorm <- cp[[1]] + probsc <- cp[[2]] + if (cond == 1) { + logliknorm = logliknorm + log(sum(probsc)) + } + if (cond == 2) { + logliknorm = logliknorm + log(probsc[S + missnumspec - soc + 1]) + } } - if(cond == 3) - { - probsn = rep(0,lx + 1) + if (cond == 3) { + probsn = rep(0, lx + 1) probsn[S + missnumspec + 1] = 1 - TT = max(1,1/abs(la - mu)) * 1E+10 * max(abs(brts)) # make this more efficient later - y = dd_integrate(probsn,c(0,TT),rhs_func_name,c(pars1,0,ddep),rtol = reltol,atol = abstol,method = methode) + TT = max(1, 1 / abs(la - mu)) * 1E+10 * max(abs(brts)) # make this more efficient later + y = dd_integrate( + initprobs = probsn, + tvec = c(0, TT), + rhs_func = rhs_func_name, + pars = c(pars1, 0, ddep), + rtol = reltol, + atol = abstol, + method = methode + ) logliknorm = log(y[2,lx + 2]) - if(soc == 2) - { + if(soc == 2) { probsn = rep(0,lx + 1) probsn[1:lx] = qn_vec[1:lx] - probsn = c(flavec(ddep,la,mu,K,r,lx,1),1) * probsn # speciation event - y = dd_integrate(probsn,c(max(abs(brts)),TT),rhs_func_name,c(pars1,1,ddep),rtol = reltol,atol = abstol,method = methode) + probsn = c(flavec(ddep, la, mu, K, r, lx, 1), 1) * probsn # speciation event + y = dd_integrate( + initprobs = probsn, + tvec = c(max(abs(brts)), TT), + rhs_func = rhs_func_name, + pars = c(pars1,1,ddep), + rtol = reltol, + atol = abstol, + method = methode + ) logliknorm = logliknorm - log(y[2,lx + 2]) } } - if(is.na(logliknorm) | is.nan(logliknorm) | logliknorm == Inf) - { + if(is.na(logliknorm) | is.nan(logliknorm) | logliknorm == Inf) { if(verbose) cat('The normalization did not yield a number.\n') loglik = -Inf - } else - { + } else { loglik = loglik - logliknorm } } } } } - if(verbose) - { + if (verbose) { s1 = sprintf('Parameters: %f %f %f',pars1[1],pars1[2],pars1[3]) - if(ddep == 5) {s1 = sprintf('%s %f',s1,pars1[4])} + if (both_rates_vary) { + s1 = sprintf('%s %f',s1,pars1[4]) + } s2 = sprintf(', Loglikelihood: %f',loglik) cat(s1,s2,"\n",sep = "") utils::flush.console() } } loglik = as.numeric(loglik) - if(is.nan(loglik) | is.na(loglik)) - { + if(is.nan(loglik) | is.na(loglik)) { loglik = -Inf } return(loglik) diff --git a/R/dd_utils.R b/R/dd_utils.R index 56eca4e..29d0be6 100644 --- a/R/dd_utils.R +++ b/R/dd_utils.R @@ -826,17 +826,15 @@ untransform_pars <- function(trpars) check_probs <- function(loglik,probs,verbose) { - probs <- probs * (probs > 0) - if(is.na(sum(probs)) | is.nan(sum(probs))) - { + probs <- pmax(probs, 0) + if (any(is.na(probs)) | any(is.nan(probs))) { if(verbose) cat('NA or NaN issues encountered.\n') loglik <- -Inf probs <- rep(-Inf,length(probs)) - } else if(sum(probs) <= 0) - { + } else if (sum(probs) <= 0) { if(verbose) cat('Probabilities smaller than 0 encountered\n') loglik <- -Inf - probs <- rep(-Inf,length(probs)) + probs <- rep(-Inf, length(probs)) } else { loglik <- loglik + log(sum(probs)) probs <- probs/sum(probs) From ca3fbb7690d1afcf22d6475ca837268998930a8e Mon Sep 17 00:00:00 2001 From: Theo Pannetier Date: Sat, 3 Apr 2021 16:07:14 +0200 Subject: [PATCH 11/49] both_rates_vary set as a separate function --- R/dd_ML.R | 68 +++++++++++++++++++++++------------------ R/dd_loglik.R | 22 ++++++------- R/dd_loglik_choosepar.R | 3 +- R/dd_utils.R | 16 +++++++++- 4 files changed, 65 insertions(+), 44 deletions(-) diff --git a/R/dd_ML.R b/R/dd_ML.R index 347c485..d268153 100644 --- a/R/dd_ML.R +++ b/R/dd_ML.R @@ -1,20 +1,17 @@ initparsoptdefault = function(ddmodel,brts,missnumspec) { - if(ddmodel < 5) - { - return(c(0.2,0.1,2 * (length(brts) + missnumspec)^(ddmodel != 2.3))) + if (both_rates_vary(ddmodel)) { + return(c(0.2, 0.1, 2 * (length(brts) + missnumspec), 0.01)) } else { - return(c(0.2,0.1,2 * (length(brts) + missnumspec),0.01)) + return(c(0.2, 0.1, 2 * (length(brts) + missnumspec) ^ (ddmodel != 2.3))) } } -parsfixdefault = function(ddmodel,brts,missnumspec,idparsopt) -{ - if(ddmodel < 5) - { - return(c(0.2,0.1,2*(length(brts) + missnumspec))[-idparsopt]) +parsfixdefault = function(ddmodel, brts, missnumspec, idparsopt) { + if (both_rates_vary(ddmodel)) { + return(c(0.2, 0.1, 2 * (length(brts) + missnumspec), 0)[-idparsopt]) } else { - return(c(0.2,0.1,2*(length(brts) + missnumspec),0)[-idparsopt]) + return(c(0.2, 0.1, 2 * (length(brts) + missnumspec))[-idparsopt]) } } @@ -136,9 +133,9 @@ dd_ML = function( brts, initparsopt = initparsoptdefault(ddmodel,brts,missnumspec), idparsopt = 1:length(initparsopt), - idparsfix = (1:(3 + (ddmodel == 5)))[-idparsopt], + idparsfix = (1:(3 + both_rates_vary(ddmodel)))[-idparsopt], parsfix = parsfixdefault(ddmodel,brts,missnumspec,idparsopt), - res = 10*(1+length(brts)+missnumspec), + res = 10 * (1 + length(brts) + missnumspec), ddmodel = 1, missnumspec = 0, cond = 1, @@ -150,33 +147,30 @@ dd_ML = function( optimmethod = 'subplex', num_cycles = 1, methode = 'analytical', - verbose = FALSE) -{ + verbose = FALSE + ) { #options(warn = -1) - if(length(tol) != 3) - { + if(length(tol) != 3) { stop('Please specify a tolerance vector with three values') } - both_rates_vary <- ddmodel %in% c(5:8, 11:13) - if (both_rates_vary) { + if (both_rates_vary(ddmodel)) { output_error <- data.frame(lambda = -1,mu = -1,K = -1, r = -1, loglik = -1, df = -1, conv = -1) } else { output_error <- data.frame(lambda = -1,mu = -1,K = -1, loglik = -1, df = -1, conv = -1) } brts = sort(abs(as.numeric(brts)),decreasing = TRUE) - if (is.numeric(brts) == FALSE) - { + if (is.numeric(brts) == FALSE) { cat("The branching times should be numeric.\n") out2 <- output_error } else { idpars = sort(c(idparsopt,idparsfix)) - if (!all(idpars == (1:(3 + both_rates_vary))) || (length(initparsopt) != length(idparsopt)) || (length(parsfix) != length(idparsfix))) + if (!all(idpars == (1:(3 + both_rates_vary(ddmodel)))) || (length(initparsopt) != length(idparsopt)) || (length(parsfix) != length(idparsfix))) { cat("The parameters to be optimized and/or fixed are incoherent.\n") out2 <- output_error } else { - if(both_rates_vary) { + if (both_rates_vary(ddmodel)) { namepars = c("lambda","mu","K","r") } else { namepars = c("lambda","mu","K") @@ -203,24 +197,40 @@ dd_ML = function( } else { #code up to DDD v1.6: out = optimx2(trparsopt,dd_loglik_choosepar,hess=NULL,method = "Nelder-Mead",hessian = FALSE,control = list(maximize = TRUE,abstol = pars2[8],reltol = pars2[7],trace = 0,starttests = FALSE,kkt = FALSE),trparsfix = trparsfix,idparsopt = idparsopt,idparsfix = idparsfix,brts = brts, pars2 = pars2,missnumspec = missnumspec) #out = dd_simplex(trparsopt,idparsopt,trparsfix,idparsfix,pars2,brts,missnumspec) - out = optimizer(optimmethod = optimmethod,optimpars = optimpars,fun = dd_loglik_choosepar,trparsopt = trparsopt,trparsfix = trparsfix,idparsopt = idparsopt,idparsfix = idparsfix,pars2 = pars2,brts = brts, missnumspec = missnumspec, methode = methode, num_cycles = num_cycles) - if(out$conv != 0) - { + out = optimizer( + optimmethod = optimmethod, + optimpars = optimpars, + fun = dd_loglik_choosepar, + trparsopt = trparsopt, + trparsfix = trparsfix, + idparsopt = idparsopt, + idparsfix = idparsfix, + pars2 = pars2, + brts = brts, + missnumspec = missnumspec, + methode = methode, + num_cycles = num_cycles + ) + if (out$conv != 0) { cat("Optimization has not converged. Try again with different initial values.\n") out2 <- output_error } else { MLtrpars = as.numeric(unlist(out$par)) MLpars = MLtrpars / (1 - MLtrpars) - if (both_rates_vary) { + if (both_rates_vary(ddmodel)) { MLpars1 <- rep(0,4) } else { MLpars1 <- rep(0,3) } MLpars1[idparsopt] = MLpars - if(length(idparsfix) != 0) { MLpars1[idparsfix] = parsfix } - if(MLpars1[3] > 10^7){MLpars1[3] = Inf} + if (length(idparsfix) != 0) { + MLpars1[idparsfix] = parsfix + } + if (MLpars1[3] > 10 ^ 7) { + MLpars1[3] = Inf + } ML = as.numeric(unlist(out$fvalues)) - if (both_rates_vary) { + if (both_rates_vary(ddmodel)) { s1 <- sprintf('Maximum likelihood parameter estimates: lambda: %f, mu: %f, K: %f, r: %f', MLpars1[1], MLpars1[2], MLpars1[3], MLpars1[4]) out2 <- data.frame(lambda = MLpars1[1], mu = MLpars1[2], K = MLpars1[3], r = MLpars1[4], loglik = ML, df = length(initparsopt), conv = unlist(out$conv)) } else { diff --git a/R/dd_loglik.R b/R/dd_loglik.R index 6781f97..d9179d7 100644 --- a/R/dd_loglik.R +++ b/R/dd_loglik.R @@ -129,18 +129,14 @@ dd_loglik_test = function(pars1,pars2,brts,missnumspec,methode = 'analytical',rh #' @export dd_loglik dd_loglik = function(pars1,pars2,brts,missnumspec,methode = 'analytical') { - if(pars2[3] == 3) - { + if(pars2[3] == 3) { rhs_func_name = 'dd_loglik_bw_rhs_FORTRAN' - } else - { + } else { rhs_func_name = 'dd_loglik_rhs_FORTRAN' } - if(methode == 'analytical') - { + if(methode == 'analytical') { out = dd_loglik2(pars1,pars2,brts,missnumspec) - } else - { + } else { out = dd_loglik1(pars1,pars2,brts,missnumspec,methode = methode,rhs_func_name = rhs_func_name) } return(out) @@ -154,7 +150,6 @@ dd_loglik1 = function(pars1,pars2,brts,missnumspec,methode = 'lsoda',rhs_func_na pars2[6] = 2 } ddep = pars2[2] - both_rates_vary <- ddep %in% c(5:8, 11:13) is_speciation_linear <- ddep %in% c(1, 1.3, 5, 6, 11) cond = pars2[3] btorph = pars2[4] @@ -166,7 +161,7 @@ dd_loglik1 = function(pars1,pars2,brts,missnumspec,methode = 'lsoda',rhs_func_na la = pars1[1] mu = pars1[2] K = pars1[3] - r <- ifelse(both_rates_vary, pars1[4], 0) + r <- ifelse(both_rates_vary(ddep), pars1[4], 0) if (is_speciation_linear) { if (ddep == 1.3) { Kprime <- ceiling(K) @@ -341,7 +336,7 @@ dd_loglik1 = function(pars1,pars2,brts,missnumspec,methode = 'lsoda',rhs_func_na } if (verbose) { s1 = sprintf('Parameters: %f %f %f',pars1[1],pars1[2],pars1[3]) - if (both_rates_vary) { + if (both_rates_vary(ddep)) { s1 = sprintf('%s %f',s1,pars1[4]) } s2 = sprintf(', Loglikelihood: %f',loglik) @@ -364,7 +359,10 @@ dd_loglik2 = function(pars1,pars2,brts,missnumspec) pars2[6] = 2 } ddep = pars2[2] - cond = pars2[3] + if (ddep > 5) { + stop("This DD model is not implemented for the analytical method yet.") + } + cond = pars2[3] btorph = pars2[4] verbose <- pars2[5] soc = pars2[6] diff --git a/R/dd_loglik_choosepar.R b/R/dd_loglik_choosepar.R index c76942a..a3d32b5 100644 --- a/R/dd_loglik_choosepar.R +++ b/R/dd_loglik_choosepar.R @@ -1,7 +1,6 @@ dd_loglik_choosepar = function(trparsopt,trparsfix,idparsopt,idparsfix,pars2,brts,missnumspec,methode) { - both_rates_vary <- pars2[2] %in% c(5:8, 11:13) - if(both_rates_vary) { + if (both_rates_vary(pars2[2])) { trpars1 = rep(0,4) } else { trpars1 = rep(0,3) diff --git a/R/dd_utils.R b/R/dd_utils.R index 29d0be6..ab11ab5 100644 --- a/R/dd_utils.R +++ b/R/dd_utils.R @@ -882,4 +882,18 @@ rng_respecting_sample <- function(x, size, replace, prob) { non_zero_prob <- prob[which_non_zero] non_zero_x <- x[which_non_zero] return(sample(x = non_zero_x, size = size, replace = replace, prob = non_zero_prob)) -} \ No newline at end of file +} + +#' Evaluate whether both speciation rates vary in specified DD model +#' +#' @param ddmodel a character or integer specifying a DD model, as described in +#' dd_loglik() and dd_ML() documentation +#' +#' @return TRUE if both speciation and extinction rates vary with N, FALSE otherwise +#' @export +#' @author Theo Pannetier +#' +both_rates_vary <- function(ddmodel) { + return(ddmodel %in% c(5:8, 11:13)) +} + From d5fdd2f45320e20d0ee58c6a7e120be2cd887096 Mon Sep 17 00:00:00 2001 From: Theo Pannetier Date: Sat, 3 Apr 2021 17:07:09 +0200 Subject: [PATCH 12/49] new DD models implemented for DD sim --- R/dd_sim.R | 65 ++++++++++++++++++++++++++++++++---------------------- 1 file changed, 39 insertions(+), 26 deletions(-) diff --git a/R/dd_sim.R b/R/dd_sim.R index b44e0a8..92d203e 100644 --- a/R/dd_sim.R +++ b/R/dd_sim.R @@ -1,57 +1,70 @@ -dd_lamuN = function(ddmodel,pars,N) -{ +dd_lamuN = function(ddmodel,pars,N) { la = pars[1] mu = pars[2] K = pars[3] n0 = (ddmodel == 2 | ddmodel == 4) - if(length(pars) == 4) - { + if(length(pars) == 4) { r = pars[4] } - if(ddmodel == 1) - { + if (ddmodel == 1) { # linear dependence in speciation rate laN = max(0,la - (la - mu) * N/K) muN = mu - } - if(ddmodel == 1.3) - { + } else if (ddmodel == 1.3) { # linear dependence in speciation rate laN = max(0,la * (1 - N/K)) muN = mu - } - if(ddmodel == 2 | ddmodel == 2.1 | ddmodel == 2.2) - { + } else if (ddmodel == 2 | ddmodel == 2.1 | ddmodel == 2.2) { # exponential dependence in speciation rate al = (log(la/mu)/log(K+n0))^(ddmodel != 2.2) laN = la * (N + n0)^(-al) muN = mu - } - if(ddmodel == 2.3) - { + } else if(ddmodel == 2.3) { # exponential dependence in speciation rate al = K laN = la * (N + n0)^(-al) muN = mu - } - if(ddmodel == 3) - { + } else if(ddmodel == 3) { # linear dependence in extinction rate laN = la muN = mu + (la - mu) * N/K - } - if(ddmodel == 4 | ddmodel == 4.1 | ddmodel == 4.2) - { + } else if(ddmodel == 4 | ddmodel == 4.1 | ddmodel == 4.2) { # exponential dependence in extinction rate al = (log(la/mu)/log(K+n0))^(ddmodel != 4.2) laN = la muN = mu * (N + n0)^al - } - if(ddmodel == 5) - { + } else if(ddmodel == 5) { # linear dependence in speciation rate and extinction rate - laN = max(0,la - 1/(r+1)*(la-mu) * N/K) - muN = mu + r/(r+1)*(la-mu)/K * N + laN = max(0, la - 1 / (r + 1) * (la - mu) * N / K) + muN = mu + r / (r + 1) * (la - mu) / K * N + } else if (ddep == 6) { + y = log((la * r + mu) / (mu * (1 + r))) / log(K) + lavec = max(0, la - 1 / (r + 1) * (la - mu) / K * N) + muvec = mu * N ^ y + } else if (ddep == 7) { + y1 = -log(la * (1 + r) / (la * r + mu)) / log(K) + y2 = log((la * r + mu) / (mu * (1 + r))) / log(K) + lavec = max(0, la * N ^ y1) + muvec = mu * N ^ y2 + } else if (ddep == 8) { + y = -log(la * (1 + r) / (la * r + mu)) / log(K) + lavec = max(0, la * N ^ y) + muvec = mu + r / (r + 1) * (la - mu) / K * N + } else if (ddep == 9) { + lavec = max(0, la * (mu / la) ^ (N / K)) + muvec = mu + } else if (ddep == 10) { + lavec = la + muvec = mu * (la / mu) ^ (N / K) + } else if (ddep == 11) { + lavec = max(0, la - 1 / (r + 1) * (la - mu) / K * N) + muvec = mu * ((r * la + mu) / (mu * (1 + r))) ^ (N / K) + } else if (ddep == 12) { + lavec = max(0, la * ((r * la + mu) / (la * (1 + r))) ^ (N / K)) + muvec = mu * ((r * la + mu) / (mu * (1 + r))) ^ (N / K) + } else if (ddep == 13) { + lavec = max(0, la * ((r * la + mu) / (la * (1 + r))) ^ (N / K)) + muvec = mu + r / (r + 1) * (la - mu) / K * N } return(c(laN,muN)) } From 39d4e9bb81d4ff3b87547a3076c4da09f6a1ad76 Mon Sep 17 00:00:00 2001 From: Theo Pannetier Date: Mon, 5 Apr 2021 18:59:07 +0200 Subject: [PATCH 13/49] test new ddmodels behave as expected --- tests/testthat/test_ddmodels.R | 209 +++++++++++++++++++++++++++++++++ 1 file changed, 209 insertions(+) create mode 100644 tests/testthat/test_ddmodels.R diff --git a/tests/testthat/test_ddmodels.R b/tests/testthat/test_ddmodels.R new file mode 100644 index 0000000..9509b5c --- /dev/null +++ b/tests/testthat/test_ddmodels.R @@ -0,0 +1,209 @@ +context("test_ddmodels") + +# I do not test models 1 through 4; these have been implemented for a long time +# and I assume they have been thoroughly tested + +# Case 1.: 0 < r < Inf (or 0 < alpha < 1) +pars_set1 <- c( + "lambda_0" = 0.8, + "mu_0" = 0.2, + "K" = 20, + "r" = 1/3 # corresponds to alpha = 1/4 +) +# cat(paste("Testing ddmodels with lambda_0 =", pars_set1[1], "mu_0 =", pars_set1[2], "K =", pars_set1[3],"alpha =", round(pars_set1[4], 3), "\n")) +# Rates obtained on paper +exptd_rates_set1 <- list( + #"lambda_cst" = function(N) 0.8, # not with alpha != 1 + #"mu_cst" = function(N) 0.2, # not with alpha != 0 + "lambda_lin" = function(N) pmax(0.8 - 0.0225 * N, 0), + "mu_lin" = function(N) 0.2 + 0.0075 * N, + "lambda_exp" = function(N) pmax(0.8 * N ^ (-log(0.8 / 0.35) / log(20)), 0), + "mu_exp" = function(N) 0.2 * N ^ (log(1.75) / log(20)), + "lambda_exp_alt" = function(N) pmax(0.8 * (7 / 16) ^ (N / 20), 0), + 'mu_exp_alt' = function(N) 0.2 * (7 / 4) ^ (N / 20) +) + +# Case 2.: r = 0 (alpha = 0) +pars_set2 <- c( + "lambda_0" = 0.8, + "mu_0" = 0.2, + "K" = 20, + "r" = 0 +) +exptd_rates_set2 <- list( + #"lambda_cst" = function(N) 0.8, # not with alpha != 1 + #"mu_cst" = function(N) 0.2, # not with alpha != 0 + "lambda_lin" = function(N) pmax(0.8 - 0.03 * N, 0), + "mu_lin" = function(N) rep(0.2, length(N)), + "lambda_exp" = function(N) pmax(0.8 * N ^ (-log(4) / log(20)), 0), + "mu_exp" = function(N) rep(0.2, length(N)), + "lambda_exp_alt" = function(N) pmax(0.8 * (1/4) ^ (N / 20), 0), + 'mu_exp_alt' = function(N) rep(0.2, length(N)) +) +# Case 3.: r = Inf (alpha = 1) +pars_set3 <- c( + "lambda_0" = 0.8, + "mu_0" = 0.2, + "K" = 20, + "r" = Inf +) +exptd_rates_set3 <- list( + #"lambda_cst" = function(N) 0.8, # not with alpha != 1 + #"mu_cst" = function(N) 0.2, # not with alpha != 0 + "lambda_lin" = function(N) rep(0.8, length(N)), + "mu_lin" = function(N) 0.2 + 0.03 * N, + "lambda_exp" = function(N) rep(0.8, length(N)), + "mu_exp" = function(N) 0.2 * N ^ (log(4) / log(20)), + "lambda_exp_alt" = function(N) rep(0.8, length(N)), + 'mu_exp_alt' = function(N) 0.2 * 4 ^ (N / 20) +) + +# Declare test functions +## Match a ddmodel digit with a set of speciation and extinction function +## See example below in exptd_rates_set1 +match_exptd_rates <- function(ddmodel, exptd_rates_set, n_seq) { + rates_ls <- switch( + as.character(ddmodel), + "5" = list("la_N" = exptd_rates_set$lambda_lin(n_seq), "mu_N" = exptd_rates_set$mu_lin(n_seq)), + "6" = list("la_N" = exptd_rates_set$lambda_lin(n_seq), "mu_N" = exptd_rates_set$mu_exp(n_seq)), + "7" = list("la_N" = exptd_rates_set$lambda_exp(n_seq), "mu_N" = exptd_rates_set$mu_exp(n_seq)), + "8" = list("la_N" = exptd_rates_set$lambda_exp(n_seq), "mu_N" = exptd_rates_set$mu_lin(n_seq)), + #"9" = list("la_N" = exptd_rates_set$lambda_exp_alt(n_seq), "mu_N" = exptd_rates_set$mu_cst(n_seq)), + #"10" = list("la_N" = exptd_rates_set$lambda_cst(n_seq), "mu_N" = exptd_rates_set$mu_exp_alt(n_seq)), + "11" = list("la_N" = exptd_rates_set$lambda_lin(n_seq), "mu_N" = exptd_rates_set$mu_exp_alt(n_seq)), + "12" = list("la_N" = exptd_rates_set$lambda_exp_alt(n_seq), "mu_N" = exptd_rates_set$mu_exp_alt(n_seq)), + "13" = list("la_N" = exptd_rates_set$lambda_exp_alt(n_seq), "mu_N" = exptd_rates_set$mu_lin(n_seq)), + ) + return(rates_ls) +} +## Test function; compare DDD output with rates obtained on paper +test_dd_loglik_rhs_precomp <- function(ddmodel, pars_set, exptd_rates_set) { + # global variables + N <- pars_set["K"] + x <- rep(NA, 10) # length of the Q_n vector + n_seq <- c(0, 0:(length(x) + 2 * N)) # based on internal code, not sure why + lnn <- length(n_seq) + + exptd_rates <- match_exptd_rates( + ddmodel = ddmodel, + exptd_rates_set = exptd_rates_set, + n_seq = n_seq + ) + ddd_output <- dd_loglik_rhs_precomp( + pars = c("pars" = pars_set, "k" = N, "ddmodel" = ddmodel), x = x + ) + ddd_rates <- list("la_N" = ddd_output[1:lnn], "mu_N" = ddd_output[(lnn + 1):(2 * lnn)]) + # Test + cat(paste("Testing ddmodel =", ddmodel, "\n")) + expect_equal(ddd_rates, exptd_rates) +} + +test_lambdamu <- function(ddmodel, pars_set, exptd_rates_set) { + # global variables + N <- pars_set["K"] + x <- rep(NA, 10) # length of the Q_n vector + n_seq <- c(0, 0:(length(x) + 2 * N)) # based on internal code, not sure why + lnn <- length(n_seq) + + exptd_rates <- match_exptd_rates( + ddmodel = ddmodel, + exptd_rates_set = exptd_rates_set, + n_seq = n_seq + ) + ddd_rates <- lambdamu(n = n_seq, pars = pars_set, ddep = ddmodel) + names(ddd_rates) <- c("la_N", "mu_N") + # Test + cat(paste("Testing ddmodel =", ddmodel, "\n")) + expect_equal(ddd_rates, exptd_rates) +} + +test_dd_lamuN <- function(ddmodel, pars_set, exptd_rates_set) { + # global variables + N <- pars_set["K"] + x <- rep(NA, 10) # length of the Q_n vector + n_seq <- c(0, 0:(length(x) + 2 * N)) # based on internal code, not sure why + + exptd_rates <- match_exptd_rates( + ddmodel = ddmodel, + exptd_rates_set = exptd_rates_set, + n_seq = n_seq + ) + ddd_rates <- list( + "la_N" = purrr::map_dbl(n_seq, function(n) { + dd_lamuN(ddmodel = ddmodel, pars = pars_set, N = n)[1] + }), + "mu_N" = purrr::map_dbl(n_seq, function(n) { + dd_lamuN(ddmodel = ddmodel, pars = pars_set, N = n)[2] + }) + ) + # Test + cat(paste("Testing ddmodel =", ddmodel, "\n")) + expect_equal(ddd_rates, exptd_rates) +} + +test_that("set1", { + ddmodels <- c(5:8, 11:13) + purrr::walk( + ddmodels, + test_dd_loglik_rhs_precomp, + pars_set = pars_set1, + exptd_rates_set = exptd_rates_set1 + ) + purrr::walk( + ddmodels, + test_lambdamu, + pars_set = pars_set1, + exptd_rates_set = exptd_rates_set1 + ) + purrr::walk( + ddmodels, + test_dd_lamuN, + pars_set = pars_set1, + exptd_rates_set = exptd_rates_set1 + ) +}) + +test_that("set2", { + ddmodels <- c(5:8, 11:13) + purrr::walk( + ddmodels, + test_dd_loglik_rhs_precomp, + pars_set = pars_set2, + exptd_rates_set = exptd_rates_set2 + ) + purrr::walk( + ddmodels, + test_lambdamu, + pars_set = pars_set2, + exptd_rates_set = exptd_rates_set2 + ) + purrr::walk( + ddmodels, + test_dd_lamuN, + pars_set = pars_set2, + exptd_rates_set = exptd_rates_set2 + ) +}) + +test_that("set3", { + ddmodels <- c(5:8, 11:13) + purrr::walk( + ddmodels, + test_dd_loglik_rhs_precomp, + pars_set = pars_set3, + exptd_rates_set = exptd_rates_set3 + ) + purrr::walk( + ddmodels, + test_lambdamu, + pars_set = pars_set3, + exptd_rates_set = exptd_rates_set3 + ) + purrr::walk( + ddmodels, + test_dd_lamuN, + pars_set = pars_set3, + exptd_rates_set = exptd_rates_set3 + ) +}) + From 2e8683803d14fdbcdad8d8e64014e5c40a491aae Mon Sep 17 00:00:00 2001 From: Theo Pannetier Date: Mon, 5 Apr 2021 19:00:33 +0200 Subject: [PATCH 14/49] subsitute par alpha for r (fix issue when r == Inf) and implement new DD models in dd_lamuN() --- R/dd_loglik_M.R | 43 ++++++++++++++---------------- R/dd_loglik_rhs.R | 31 +++++++++++----------- R/dd_sim.R | 66 ++++++++++++++++++++++++----------------------- 3 files changed, 70 insertions(+), 70 deletions(-) diff --git a/R/dd_loglik_M.R b/R/dd_loglik_M.R index bd05e87..13ac9cb 100644 --- a/R/dd_loglik_M.R +++ b/R/dd_loglik_M.R @@ -5,6 +5,7 @@ lambdamu = function(n,pars,ddep) mu = pars[2] K = pars[3] r = pars[4] + alpha <- ifelse(r == Inf, 1, r / (1 + r)) # else r/(1+r) can be NaN n0 = (ddep == 2 | ddep == 4) if(ddep == 1) { lavec = pmax(0, la - (la - mu) * n / K) @@ -16,37 +17,33 @@ lambdamu = function(n,pars,ddep) y = -(log(la / mu) / log(K + n0)) ^ (ddep != 2.2) lavec = pmax(0, la * (n + n0) ^ y) muvec = rep(mu, lnn) - } else if(ddep == 2.3) - { + } else if(ddep == 2.3) { y = -K lavec = pmax(0, la * (n + n0) ^ y) muvec = rep(mu, lnn) - } else if(ddep == 3) - { + } else if(ddep == 3) { lavec = rep(la, lnn) muvec = mu + (la - mu) * n/K - } else if (ddep == 4 | ddep == 4.1 | ddep == 4.2) - { + } else if (ddep == 4 | ddep == 4.1 | ddep == 4.2) { y = (log(la / mu) / log(K + n0)) ^ (ddep != 4.2) lavec = rep(la, lnn) muvec = mu * (n + n0) ^ y - } else if (ddep == 5) - { - lavec = pmax(0, la - 1 / (r + 1) * (la - mu) / K * n) - muvec = muvec = mu + r / (r + 1) * (la - mu) / K * n - } else if (ddep == 6) { - y = log((la * r + mu) / (mu * (1 + r))) / log(K) - lavec = pmax(0, la - 1 / (r + 1) * (la - mu) / K * n) + } else if (ddep == 5) { + lavec = pmax(0, la - (1 - alpha) * (la - mu) * n / K) + muvec = mu + alpha * (la - mu) * n / K + } else if (ddep == 6) { + y = log(1 + alpha * (la - mu) / mu) / log(K) + lavec = pmax(0, la - (1 - alpha) * (la - mu) * n / K) muvec = mu * n ^ y } else if (ddep == 7) { - y1 = -log(la * (1 + r) / (la * r + mu)) / log(K) - y2 = log((la * r + mu) / (mu * (1 + r))) / log(K) + y1 = -log(la / (alpha * (la - mu) + mu)) / log(K) + y2 = log(1 + alpha * (la - mu) / mu) / log(K) lavec = pmax(0, la * n ^ y1) muvec = mu * n ^ y2 } else if (ddep == 8) { - y = -log(la * (1 + r) / (la * r + mu)) / log(K) + y = -log(la / (alpha * (la - mu) + mu)) / log(K) lavec = pmax(0, la * n ^ y) - muvec = mu + r / (r + 1) * (la - mu) / K * n + muvec = mu + alpha * (la - mu) / K * n } else if (ddep == 9) { lavec = pmax(0, la * (mu / la) ^ (n / K)) muvec = rep(mu, lnn) @@ -54,14 +51,14 @@ lambdamu = function(n,pars,ddep) lavec = rep(la, lnn) muvec = mu * (la / mu) ^ (n / K) } else if (ddep == 11) { - lavec = pmax(0, la - 1 / (r + 1) * (la - mu) / K * n) - muvec = mu * ((r * la + mu) / (mu * (1 + r))) ^ (n / K) + lavec = pmax(0, la - (1 - alpha) * (la - mu) * n / K) + muvec = mu * (1 + alpha * (la - mu) / mu) ^ (n / K) } else if (ddep == 12) { - lavec = pmax(0, la * ((r * la + mu) / (la * (1 + r))) ^ (n / K)) - muvec = mu * ((r * la + mu) / (mu * (1 + r))) ^ (n / K) + lavec = pmax(0, la * ((alpha * (la - mu) + mu) / la) ^ (n / K)) + muvec = mu * (1 + alpha * (la - mu) / mu) ^ (n / K) } else if (ddep == 13) { - lavec = pmax(0, la * ((r * la + mu) / (la * (1 + r))) ^ (n / K)) - muvec = mu + r / (r + 1) * (la - mu) / K * n + lavec = pmax(0, la * ((alpha * (la - mu) + mu) / la) ^ (n / K)) + muvec = mu + alpha * (la - mu) * n / K } return(list(lavec,muvec)) } diff --git a/R/dd_loglik_rhs.R b/R/dd_loglik_rhs.R index f4f1bed..e192a96 100644 --- a/R/dd_loglik_rhs.R +++ b/R/dd_loglik_rhs.R @@ -11,6 +11,7 @@ dd_loglik_rhs_precomp = function(pars,x) r = pars[4] kk = pars[5] ddep = pars[6] + alpha <- ifelse(r == Inf, 1, r / (1 + r)) # else r/(1+r) can be NaN } n0 = (ddep == 2 | ddep == 4) @@ -43,22 +44,22 @@ dd_loglik_rhs_precomp = function(pars,x) lavec = rep(la, lnn) y = (log(la / mu) / log(K + n0)) ^ (ddep != 4.2) muvec = mu * (nn + n0) ^ y - } else if (ddep == 5) { - lavec = pmax(0, la - 1 / (r + 1) * (la - mu) / K * nn) - muvec = mu + r / (r + 1) * (la - mu) / K * nn + } else if (ddep == 5) { + lavec = pmax(0, la - (1 - alpha) * (la - mu) * nn / K) + muvec = mu + alpha * (la - mu) / K * nn } else if (ddep == 6) { - y = log((la * r + mu) / (mu * (1 + r))) / log(K) - lavec = pmax(0, la - 1 / (r + 1) * (la - mu) / K * nn) + y = log(1 + alpha * (la - mu) / mu) / log(K) + lavec = pmax(0, la - (1 - alpha) * (la - mu) * nn / K) muvec = mu * nn ^ y } else if (ddep == 7) { - y1 = -log(la * (1 + r) / (la * r + mu)) / log(K) - y2 = log((la * r + mu) / (mu * (1 + r))) / log(K) + y1 = -log(la / (alpha * (la - mu) + mu)) / log(K) + y2 = log(1 + alpha * (la - mu) / mu) / log(K) lavec = pmax(0, la * nn ^ y1) muvec = mu * nn ^ y2 } else if (ddep == 8) { - y = -log(la * (1 + r) / (la * r + mu)) / log(K) + y = -log(la / (alpha * (la - mu) + mu)) / log(K) lavec = pmax(0, la * nn ^ y) - muvec = mu + r / (r + 1) * (la - mu) / K * nn + muvec = mu + alpha * (la - mu) / K * nn } else if (ddep == 9) { lavec = pmax(0, la * (mu / la) ^ (nn / K)) muvec = rep(mu, lnn) @@ -66,14 +67,14 @@ dd_loglik_rhs_precomp = function(pars,x) lavec = rep(la, lnn) muvec = mu * (la / mu) ^ (nn / K) } else if (ddep == 11) { - lavec = pmax(0, la - 1 / (r + 1) * (la - mu) / K * nn) - muvec = mu * ((r * la + mu) / (mu * (1 + r))) ^ (nn / K) + lavec = pmax(0, la - (1 - alpha) * (la - mu) * nn / K ) + muvec = mu * (1 + alpha * (la - mu) / mu) ^ (nn / K) } else if (ddep == 12) { - lavec = pmax(0, la * ((r * la + mu) / (la * (1 + r))) ^ (nn / K)) - muvec = mu * ((r * la + mu) / (mu * (1 + r))) ^ (nn / K) + lavec = pmax(0, la * ((alpha * (la - mu) + mu) / la) ^ (nn / K)) + muvec = mu * (1 + alpha * (la - mu) / mu) ^ (nn / K) } else if (ddep == 13) { - lavec = pmax(0, la * ((r * la + mu) / (la * (1 + r))) ^ (nn / K)) - muvec = mu + r / (r + 1) * (la - mu) / K * nn + lavec = pmax(0, la * ((alpha * (la - mu) + mu) / la) ^ (nn / K)) + muvec = mu + alpha * (la - mu) / K * nn } return(c(lavec, muvec, nn)) } diff --git a/R/dd_sim.R b/R/dd_sim.R index 92d203e..fb34ff6 100644 --- a/R/dd_sim.R +++ b/R/dd_sim.R @@ -1,10 +1,12 @@ dd_lamuN = function(ddmodel,pars,N) { + testthat::expect_length(N, 1) la = pars[1] mu = pars[2] K = pars[3] n0 = (ddmodel == 2 | ddmodel == 4) - if(length(pars) == 4) { + if (length(pars) == 4) { r = pars[4] + alpha <- ifelse(r == Inf, 1, r / (1 + r)) } if (ddmodel == 1) { # linear dependence in speciation rate @@ -33,38 +35,38 @@ dd_lamuN = function(ddmodel,pars,N) { al = (log(la/mu)/log(K+n0))^(ddmodel != 4.2) laN = la muN = mu * (N + n0)^al - } else if(ddmodel == 5) { + } else if (ddmodel == 5) { # linear dependence in speciation rate and extinction rate - laN = max(0, la - 1 / (r + 1) * (la - mu) * N / K) - muN = mu + r / (r + 1) * (la - mu) / K * N - } else if (ddep == 6) { - y = log((la * r + mu) / (mu * (1 + r))) / log(K) - lavec = max(0, la - 1 / (r + 1) * (la - mu) / K * N) - muvec = mu * N ^ y - } else if (ddep == 7) { - y1 = -log(la * (1 + r) / (la * r + mu)) / log(K) - y2 = log((la * r + mu) / (mu * (1 + r))) / log(K) - lavec = max(0, la * N ^ y1) - muvec = mu * N ^ y2 - } else if (ddep == 8) { - y = -log(la * (1 + r) / (la * r + mu)) / log(K) - lavec = max(0, la * N ^ y) - muvec = mu + r / (r + 1) * (la - mu) / K * N - } else if (ddep == 9) { - lavec = max(0, la * (mu / la) ^ (N / K)) - muvec = mu - } else if (ddep == 10) { - lavec = la - muvec = mu * (la / mu) ^ (N / K) - } else if (ddep == 11) { - lavec = max(0, la - 1 / (r + 1) * (la - mu) / K * N) - muvec = mu * ((r * la + mu) / (mu * (1 + r))) ^ (N / K) - } else if (ddep == 12) { - lavec = max(0, la * ((r * la + mu) / (la * (1 + r))) ^ (N / K)) - muvec = mu * ((r * la + mu) / (mu * (1 + r))) ^ (N / K) - } else if (ddep == 13) { - lavec = max(0, la * ((r * la + mu) / (la * (1 + r))) ^ (N / K)) - muvec = mu + r / (r + 1) * (la - mu) / K * N + laN = max(0, la - (1 - alpha) * (la - mu) * N / K) + muN = mu + alpha * (la - mu) * N / K + } else if (ddmodel == 6) { + y = log(1 + alpha * (la - mu) / mu) / log(K) + laN = max(0, la - (1 - alpha) * (la - mu) * N / K) + muN = mu * N ^ y + } else if (ddmodel == 7) { + y1 = -log(la / (alpha * (la - mu) + mu)) / log(K) + y2 = log(1 + alpha * (la - mu) / mu) / log(K) + laN = max(0, la * N ^ y1) + muN = mu * N ^ y2 + } else if (ddmodel == 8) { + y = -log(la / (alpha * (la - mu) + mu)) / log(K) + laN = max(0, la * N ^ y) + muN = mu + alpha * (la - mu) / K * N + } else if (ddmodel == 9) { + laN = max(0, la * (mu / la) ^ (N / K)) + muN = mu + } else if (ddmodel == 10) { + laN = la + muN = mu * (la / mu) ^ (N / K) + } else if (ddmodel == 11) { + laN = max(0, la - (1 - alpha) * (la - mu) / K * N) + muN = mu * (1 + alpha * (la - mu) / mu) ^ (N / K) + } else if (ddmodel == 12) { + laN = max(0, la * ((alpha * (la - mu) + mu) / la) ^ (N / K)) + muN = mu * (1 + alpha * (la - mu) / mu) ^ (N / K) + } else if (ddmodel == 13) { + laN = max(0, la * ((alpha * (la - mu) + mu) / la) ^ (N / K)) + muN = mu + alpha * (la - mu) / K * N } return(c(laN,muN)) } From 801f38bdd6cc674cdb38add96c0551c2d0ff4f82 Mon Sep 17 00:00:00 2001 From: Theo Pannetier Date: Thu, 8 Apr 2021 21:48:12 +0200 Subject: [PATCH 15/49] shortcut function for Kprime --- NAMESPACE | 1 + R/dd_utils.R | 34 ++++++++++++++++++++++++++++++++++ man/get_Kprime.Rd | 28 ++++++++++++++++++++++++++++ 3 files changed, 63 insertions(+) create mode 100644 man/get_Kprime.Rd diff --git a/NAMESPACE b/NAMESPACE index a638bec..906b361 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -19,6 +19,7 @@ export(dd_SR_loglik) export(dd_SR_sim) export(dd_loglik) export(dd_sim) +export(get_Kprime) export(optimizer) export(phylo2L) export(rng_respecting_sample) diff --git a/R/dd_utils.R b/R/dd_utils.R index ab11ab5..eb1457a 100644 --- a/R/dd_utils.R +++ b/R/dd_utils.R @@ -897,3 +897,37 @@ both_rates_vary <- function(ddmodel) { return(ddmodel %in% c(5:8, 11:13)) } +#' Get carrying capacity from other parameters of the model +#' +#' Compute the carrying capacity K', the maximum diversity that is possible to reach +#' with the model, i.e. the value of N for which lambda(N) = 0. +#' This is different from K, the equilibrium diversity, i.e. the value of N for +#' which lambda(N) = mu(N). +#' +#' @param ddmodel a character or integer specifying a DD model, as described in +#' dd_loglik() and dd_ML() documentation +#' @param pars a numeric vector containing parameter values of the DD model. +#' \code{pars[1]} is the lambda0, \code{pars[2]} is mu0, \code{pars[3]} is K +#' and \code{pars[4]}, if relevant, is r. +#' +#' @export +#' @author Theo Pannetier +#' @return a numeric value, K' + +get_Kprime <- function(ddmodel, pars) { + la <- pars[1] + mu <- pars[2] + K <- pars[3] + if (ddmodel == 1) { + Kprime <- la / (la - mu) * K + } else if (ddmodel == 1.3) { + Kprime <- K + } else if (ddmodel %in% c(5, 6, 11)) { + r <- pars[4] + Kprime <- (1 + r) * la / (la - mu) * K + } else { + Kprime <- Inf + } + return(Kprime) +} + diff --git a/man/get_Kprime.Rd b/man/get_Kprime.Rd new file mode 100644 index 0000000..2f1ff3e --- /dev/null +++ b/man/get_Kprime.Rd @@ -0,0 +1,28 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/dd_utils.R +\name{get_Kprime} +\alias{get_Kprime} +\title{Get carrying capacity from other parameters of the model} +\usage{ +get_Kprime(ddmodel, pars) +} +\arguments{ +\item{ddmodel}{a character or integer specifying a DD model, as described in +dd_loglik() and dd_ML() documentation} + +\item{pars}{a numeric vector containing parameter values of the DD model. +\code{pars[1]} is the lambda0, \code{pars[2]} is mu0, \code{pars[3]} is K +and \code{pars[4]}, if relevant, is r.} +} +\value{ +a numeric value, K' +} +\description{ +Compute the carrying capacity K', the maximum diversity that is possible to reach +with the model, i.e. the value of N for which lambda(N) = 0. +This is different from K, the equilibrium diversity, i.e. the value of N for +which lambda(N) = mu(N). +} +\author{ +Theo Pannetier +} From 01c33601489a9fbb816cf3185b6fa63b7a8474b1 Mon Sep 17 00:00:00 2001 From: Theo Pannetier Date: Thu, 8 Apr 2021 21:49:15 +0200 Subject: [PATCH 16/49] renamed test file so it runs last --- tests/testthat/{test_DDD.R => test_z_DDD.R} | 31 +++++++++++---------- 1 file changed, 16 insertions(+), 15 deletions(-) rename tests/testthat/{test_DDD.R => test_z_DDD.R} (87%) diff --git a/tests/testthat/test_DDD.R b/tests/testthat/test_z_DDD.R similarity index 87% rename from tests/testthat/test_DDD.R rename to tests/testthat/test_z_DDD.R index 30a833e..9112c12 100644 --- a/tests/testthat/test_DDD.R +++ b/tests/testthat/test_z_DDD.R @@ -1,5 +1,6 @@ context("test_DDD") +# file named z_DDD so tests run last test_that("DDD works", { expect_equal_x64 <- function(object, expected, ...) { @@ -19,10 +20,10 @@ test_that("DDD works", { missnumspec = 0 methode = 'lsoda' - r0 <- DDD:::dd_loglik(pars1 = pars1,pars2 = pars2,brts = brts,missnumspec = missnumspec,methode = methode) - r1 <- DDD:::dd_loglik_test(pars1 = pars1,pars2 = pars2,brts = brts,missnumspec = missnumspec,rhs_func_name = 'dd_loglik_rhs',methode = methode) - r2 <- DDD:::dd_loglik_test(pars1 = pars1,pars2 = pars2,brts = brts,missnumspec = missnumspec,rhs_func_name = 'dd_loglik_rhs_FORTRAN',methode = methode) - r3 <- DDD:::dd_loglik_test(pars1 = pars1,pars2 = pars2,brts = brts,missnumspec = missnumspec,methode = 'analytical') + r0 <- dd_loglik(pars1 = pars1,pars2 = pars2,brts = brts,missnumspec = missnumspec,methode = methode) + r1 <- dd_loglik(pars1 = pars1,pars2 = pars2,brts = brts,missnumspec = missnumspec,rhs_func_name = 'dd_loglik_rhs', methode = methode) + r2 <- dd_loglik(pars1 = pars1,pars2 = pars2,brts = brts,missnumspec = missnumspec,rhs_func_name = 'dd_loglik_rhs_FORTRAN',methode = methode) + r3 <- dd_loglik(pars1 = pars1,pars2 = pars2,brts = brts,missnumspec = missnumspec,methode = 'analytical') testthat::expect_equal(r0,r2,tolerance = .00001) testthat::expect_equal(r1,r2,tolerance = .00001) @@ -34,9 +35,9 @@ test_that("DDD works", { brts = 1:5 pars2 = c(100,1,3,0,0,2) - r5 <- DDD:::dd_loglik_test(pars1 = pars1,pars2 = pars2,brts = brts,missnumspec = missnumspec,rhs_func_name = 'dd_loglik_bw_rhs',methode = methode) - r6 <- DDD:::dd_loglik_test(pars1 = pars1,pars2 = pars2,brts = brts,missnumspec = missnumspec,rhs_func_name = 'dd_loglik_bw_rhs_FORTRAN',methode = methode) - r7 <- DDD:::dd_loglik_test(pars1 = pars1,pars2 = pars2,brts = brts,missnumspec = missnumspec,methode = 'analytical') + r5 <- dd_loglik(pars1 = pars1,pars2 = pars2,brts = brts,missnumspec = missnumspec,rhs_func_name = 'dd_loglik_bw_rhs',methode = methode) + r6 <- dd_loglik(pars1 = pars1,pars2 = pars2,brts = brts,missnumspec = missnumspec,rhs_func_name = 'dd_loglik_bw_rhs_FORTRAN',methode = methode) + r7 <- dd_loglik(pars1 = pars1,pars2 = pars2,brts = brts,missnumspec = missnumspec,methode = 'analytical') testthat::expect_equal(r5,r6,tolerance = .00001) testthat::expect_equal(r5,r7,tolerance = .01) @@ -45,8 +46,8 @@ test_that("DDD works", { pars1 = c(0.2,0.05,1000000) pars2 = c(1000,1,1,0,0,2) brts = 1:10 - r8 <- DDD:::dd_loglik_test(pars1 = pars1,pars2 = pars2,brts = brts,missnumspec = missnumspec,rhs_func_name = 'dd_loglik_rhs_FORTRAN',methode = methode) - r9 <- DDD:::dd_loglik_test(pars1 = c(pars1[1:2],Inf),pars2 = pars2,brts = brts,missnumspec = missnumspec,rhs_func_name = 'dd_loglik_rhs_FORTRAN',methode = methode) + r8 <- dd_loglik(pars1 = pars1,pars2 = pars2,brts = brts,missnumspec = missnumspec,rhs_func_name = 'dd_loglik_rhs_FORTRAN',methode = methode) + r9 <- dd_loglik(pars1 = c(pars1[1:2],Inf),pars2 = pars2,brts = brts,missnumspec = missnumspec,rhs_func_name = 'dd_loglik_rhs_FORTRAN',methode = methode) expect_equal_x64(r8,r9,tolerance = .00001) pars1 <- c(0.2,0.05,15) @@ -282,7 +283,7 @@ test_that("conditioning_DDD_KI works", for(i in 1:5) { brts_k_list <- list(rbind(c(-10,ts[i],0),c(2,1,1)),rbind(c(ts[i],0),c(1,1))) - p1[i] <- DDD:::dd_multiple_KI_logliknorm(brts_k_list = brts_k_list, + p1[i] <- dd_multiple_KI_logliknorm(brts_k_list = brts_k_list, pars1_list = pars1_list, pars2 = c(200,1,5,NA,1,2,3), loglik = 0, @@ -290,7 +291,7 @@ test_that("conditioning_DDD_KI works", reltol = reltol, abstol = abstol, methode = 'ode45') - p2[i] <- DDD:::dd_KI_logliknorm(brts_k_list = brts_k_list, + p2[i] <- dd_KI_logliknorm(brts_k_list = brts_k_list, pars1_list = pars1_list, loglik = 0, cond = 5, @@ -309,7 +310,7 @@ test_that("conditioning_DDD_KI works", pars2 <- c(500,1,5,NA,1,2,3) lx_list <- list(pars2[1],pars2[1]) brts_k_list <- list(rbind(sort(c(-10:-6,-3,-1,0)),c(2,3,4,5,6,5,6,6)),rbind(c(-3,-2,0),c(1,2,2))) - logliknorm1 <- DDD:::dd_KI_logliknorm(brts_k_list = brts_k_list, + logliknorm1 <- dd_KI_logliknorm(brts_k_list = brts_k_list, pars1_list = pars1_list, loglik = 0, cond = 5, @@ -318,7 +319,7 @@ test_that("conditioning_DDD_KI works", reltol = reltol, abstol = abstol, methode = 'ode45') - logliknorm2 <- DDD:::dd_multiple_KI_logliknorm(brts_k_list = brts_k_list, + logliknorm2 <- dd_multiple_KI_logliknorm(brts_k_list = brts_k_list, pars1_list = pars1_list, pars2 = pars2, loglik = 0, @@ -332,7 +333,7 @@ test_that("conditioning_DDD_KI works", pars2 <- c(500,1,5,NA,1,2,3) lx_list <- list(pars2[1],pars2[1]) brts_k_list <- list(rbind(c(-10:-6,-3,-1,0),c(2,3,4,5,6,5,6,6)),rbind(c(-3,-2,0),c(1,2,2))) - logliknorm1 <- DDD:::dd_KI_logliknorm(brts_k_list = brts_k_list, + logliknorm1 <- dd_KI_logliknorm(brts_k_list = brts_k_list, pars1_list = pars1_list, loglik = 0, cond = 5, @@ -341,7 +342,7 @@ test_that("conditioning_DDD_KI works", reltol = reltol, abstol = abstol, methode = 'ode45') - logliknorm2 <- DDD:::dd_multiple_KI_logliknorm(brts_k_list = brts_k_list, + logliknorm2 <- dd_multiple_KI_logliknorm(brts_k_list = brts_k_list, pars1_list = pars1_list, pars2 = pars2, loglik = 0, From 1183912ea76752f969e596c073de41727352cce4 Mon Sep 17 00:00:00 2001 From: Theo Pannetier Date: Thu, 8 Apr 2021 21:50:33 +0200 Subject: [PATCH 17/49] both_rates_vary doc --- man/both_rates_vary.Rd | 19 +++++++++++++++++++ man/dd_ML.Rd | 2 +- 2 files changed, 20 insertions(+), 1 deletion(-) create mode 100644 man/both_rates_vary.Rd diff --git a/man/both_rates_vary.Rd b/man/both_rates_vary.Rd new file mode 100644 index 0000000..6ac127f --- /dev/null +++ b/man/both_rates_vary.Rd @@ -0,0 +1,19 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/dd_utils.R +\name{both_rates_vary} +\alias{both_rates_vary} +\title{Evaluate whether both speciation rates vary in specified DD model} +\usage{ +both_rates_vary(ddmodel) +} +\arguments{ +\item{ddmodel}{a character or integer specifying a DD model, as described in +dd_loglik() and dd_ML() documentation + +@return TRUE if both speciation and extinction rates vary with N, FALSE otherwise +@export +@author Theo Pannetier} +} +\description{ +Evaluate whether both speciation rates vary in specified DD model +} diff --git a/man/dd_ML.Rd b/man/dd_ML.Rd index 2450bbb..3a3ee90 100644 --- a/man/dd_ML.Rd +++ b/man/dd_ML.Rd @@ -9,7 +9,7 @@ dd_ML( brts, initparsopt = initparsoptdefault(ddmodel, brts, missnumspec), idparsopt = 1:length(initparsopt), - idparsfix = (1:(3 + (ddmodel == 5)))[-idparsopt], + idparsfix = (1:(3 + both_rates_vary(ddmodel)))[-idparsopt], parsfix = parsfixdefault(ddmodel, brts, missnumspec, idparsopt), res = 10 * (1 + length(brts) + missnumspec), ddmodel = 1, From 31ee34d6fb1bdfef13da18050b8222240b82e316 Mon Sep 17 00:00:00 2001 From: Theo Pannetier Date: Thu, 8 Apr 2021 21:51:26 +0200 Subject: [PATCH 18/49] reworked syntax for more clarity, additional parameter control for new models --- R/dd_loglik.R | 346 +++++++++++++++++++++++------------------------ man/dd_loglik.Rd | 10 +- 2 files changed, 178 insertions(+), 178 deletions(-) diff --git a/R/dd_loglik.R b/R/dd_loglik.R index d9179d7..10ec6ce 100644 --- a/R/dd_loglik.R +++ b/R/dd_loglik.R @@ -32,11 +32,9 @@ dd_loglik_test = function(pars1,pars2,brts,missnumspec,methode = 'analytical',rhs_func_name = 'dd_loglik_rhs') { - if(methode == 'analytical') - { + if (methode == 'analytical') { out = dd_loglik2(pars1,pars2,brts,missnumspec) - } else - { + } else { out = dd_loglik1(pars1,pars2,brts,missnumspec,methode = methode,rhs_func_name = rhs_func_name) } return(out) @@ -127,14 +125,17 @@ dd_loglik_test = function(pars1,pars2,brts,missnumspec,methode = 'analytical',rh #' @examples #' dd_loglik(pars1 = c(0.5,0.1,100), pars2 = c(100,1,1,1,0,2), brts = 1:10, missnumspec = 0) #' @export dd_loglik -dd_loglik = function(pars1,pars2,brts,missnumspec,methode = 'analytical') -{ - if(pars2[3] == 3) { - rhs_func_name = 'dd_loglik_bw_rhs_FORTRAN' - } else { - rhs_func_name = 'dd_loglik_rhs_FORTRAN' +dd_loglik = function(pars1, + pars2, + brts, + missnumspec = 0, + methode = "analytical", + rhs_func_name = ifelse(pars2[3] == 3, "dd_loglik_bw_rhs_FORTRAN", 'dd_loglik_rhs_FORTRAN') +) { + if (pars2[3] == 3 & !rhs_func_name %in% c("dd_loglik_bw_rhs", "dd_loglik_bw_rhs_FORTRAN")) { + stop("For \"cond = 3\" rhs_func_name should be \"dd_loglik_bw_rhs\" or \"dd_loglik_bw_rhs_FORTRAN\"") } - if(methode == 'analytical') { + if (methode == 'analytical') { out = dd_loglik2(pars1,pars2,brts,missnumspec) } else { out = dd_loglik1(pars1,pars2,brts,missnumspec,methode = methode,rhs_func_name = rhs_func_name) @@ -142,15 +143,13 @@ dd_loglik = function(pars1,pars2,brts,missnumspec,methode = 'analytical') return(out) } -dd_loglik1 = function(pars1,pars2,brts,missnumspec,methode = 'lsoda',rhs_func_name = 'dd_loglik_rhs_FORTRAN') -{ - if(length(pars2) == 4) - { +dd_loglik1 = function(pars1,pars2,brts,missnumspec,methode = 'lsoda',rhs_func_name = 'dd_loglik_rhs_FORTRAN') { + # Unpack pars2 + if (length(pars2) == 4) { pars2[5] = 0 pars2[6] = 2 } ddep = pars2[2] - is_speciation_linear <- ddep %in% c(1, 1.3, 5, 6, 11) cond = pars2[3] btorph = pars2[4] verbose = pars2[5] @@ -158,24 +157,17 @@ dd_loglik1 = function(pars1,pars2,brts,missnumspec,methode = 'lsoda',rhs_func_na if(cond == 3) { soc = 2 } + # Unpack pars1 la = pars1[1] mu = pars1[2] K = pars1[3] r <- ifelse(both_rates_vary(ddep), pars1[4], 0) - if (is_speciation_linear) { - if (ddep == 1.3) { - Kprime <- ceiling(K) - } else { - Kprime <- ceiling(la / (la - mu) * (r + 1) * K) - } - } else { - Kprime <- Inf - } + Kprime <- get_Kprime(ddep, pars1) + is_speciation_linear <- ddep %in% c(1, 1.3, 5, 6, 11) - lx = min(max(1 + missnumspec,1 + Kprime), ceiling(pars2[1])) + lx = min(max(1 + missnumspec, 1 + Kprime), ceiling(pars2[1])) - if((ddep == 1) & ((mu == 0 & missnumspec == 0 & floor(K) != ceiling(K) & la > 0.05) | K == Inf)) - { + if ((ddep == 1) & ((mu == 0 & missnumspec == 0 & floor(K) != ceiling(K) & la > 0.05) | K == Inf)) { loglik = bd_loglik(pars1[1:(2 + (K < Inf))],c(2*(mu == 0 & K < Inf),pars2[3:6]),brts,missnumspec) } else { abstol = 1e-16 @@ -185,164 +177,164 @@ dd_loglik1 = function(pars1,pars2,brts,missnumspec,methode = 'lsoda',rhs_func_na brts[length(brts) + 1] = 0 } S = length(brts) + (soc - 2) - if(min(pars1) < 0) - { - if(verbose) cat('The parameters are negative.\n') + if (any(pars1 < 0)) { + if (verbose) cat('Model parameters cannot be negative.\n') + loglik = -Inf + } else if (la == 0) { + if (verbose) cat('la0 cannot be zero.\n') + loglik = -Inf + } else if (ddep %in% c(2, 2.1, 2.1, 4, 6, 7, 10:12) && mu == 0) { + if (verbose) cat('mu0 cannot be exactly zero for this model.\n') + loglik = -Inf + } else if (ddep == 8 && mu == 0 && r == 0) { + if (verbose) cat('mu0 and r cannot both be zero for this model.\n') + loglik = -Inf + } else if (is_speciation_linear && Kprime < missnumspec + S) { + if (verbose) cat('K\' cannot be smaller than the nb of species in the tree.\n') + loglik = -Inf + } else if (la <= mu) { + if(verbose) cat("lambda0 cannot be smaller than mu0.\n") loglik = -Inf } else { - if((mu == 0 & (ddep == 2 | ddep == 2.1 | ddep == 2.2)) | (la == 0 & (ddep == 4 | ddep == 4.1 | ddep == 4.2)) | (la <= mu)) - { - if(verbose) cat("These parameter values cannot satisfy lambda(N) = mu(N) for a positive and finite N.\n") + loglik = (btorph == 0) * lgamma(S) + if (cond != 3) { + qn_vec = rep(0,lx) + qn_vec[1] = 1 # change if other species at stem/crown age + for (k in 2:(S + 2 - soc)) { + k1 = k + (soc - 2) + y <- dd_integrate( + initprobs = qn_vec, + tvec = brts[(k-1):k], + rhs_func = rhs_func_name, + pars = c(pars1,k1,ddep), + rtol = reltol, + atol = abstol, + method = methode + ) + qn_vec = y[2, 2:(lx+1)] + + if (any(is.na(qn_vec)) && pars1[2] / pars1[1] < 1E-4 && missnumspec == 0) { + loglik = dd_loglik_high_lambda(pars1 = pars1, pars2 = pars2, brts = brts) + if (verbose) cat('High lambda approximation has been applied.\n') + return(loglik) + } + if (k < (S + 2 - soc)) { + qn_vec <- flavec(ddep, la, mu, K, r, lx, k1) * qn_vec # transition vector + } + cp <- check_probs(loglik, qn_vec, verbose) + loglik <- cp[[1]] + qn_vec <- cp[[2]] + } + } else { # cond == 3 + qn_vec = rep(0,lx + 1) + qn_vec[1 + missnumspec] = 1 + for (k in (S + 2 - soc):2) { + k1 = k + (soc - 2) + y = dd_integrate( + initprobs = qn_vec, + tvec = -brts[k:(k-1)], + rhs_func = rhs_func_name, + pars = c(pars1,k1,ddep), + rtol = reltol, + atol = abstol, + method = methode + ) + qn_vec = y[2,2:(lx+2)] + if(k > soc) { + qn_vec = c(flavec(ddep,la,mu,K,r,lx,k1-1),1) * qn_vec # speciation event + } + cp <- check_probs(loglik,qn_vec[1:lx],verbose) + loglik <- cp[[1]] + qn_vec[1:lx] <- cp[[2]] + } + } + if (qn_vec[1 + missnumspec] <= 0 | loglik == -Inf | is.na(loglik) | is.nan(loglik)) { + if(verbose) cat('Probabilities smaller than 0 or other numerical problems are encountered in final result.\n') loglik = -Inf } else { - if (is_speciation_linear && Kprime < missnumspec + S) { - if (verbose) cat('The parameters are incompatible.\n') - loglik = -Inf - } else { - loglik = (btorph == 0) * lgamma(S) - if (cond != 3) { - qn_vec = rep(0,lx) - qn_vec[1] = 1 # change if other species at stem/crown age - for (k in 2:(S + 2 - soc)) { - k1 = k + (soc - 2) - y <- dd_integrate( - initprobs = qn_vec, - tvec = brts[(k-1):k], - rhs_func = rhs_func_name, - pars = c(pars1,k1,ddep), - rtol = reltol, - atol = abstol, - method = methode - ) - qn_vec = y[2, 2:(lx+1)] - - if (any(is.na(qn_vec)) && pars1[2] / pars1[1] < 1E-4 && missnumspec == 0) { - loglik = dd_loglik_high_lambda(pars1 = pars1, pars2 = pars2, brts = brts) - if (verbose) cat('High lambda approximation has been applied.\n') - return(loglik) - } - if (k < (S + 2 - soc)) { - qn_vec <- flavec(ddep, la, mu, K, r, lx, k1) * qn_vec # transition vector - } - cp <- check_probs(loglik, qn_vec, verbose) - loglik <- cp[[1]] - qn_vec <- cp[[2]] - } - } else { - qn_vec = rep(0,lx + 1) - qn_vec[1 + missnumspec] = 1 - for(k in (S + 2 - soc):2) - { - k1 = k + (soc - 2) - y = dd_integrate( - initprobs = qn_vec, - tvec = -brts[k:(k-1)], - rhs_func = rhs_func_name, - pars = c(pars1,k1,ddep), - rtol = reltol, - atol = abstol, - method = methode - ) - qn_vec = y[2,2:(lx+2)] - if(k > soc) - { - qn_vec = c(flavec(ddep,la,mu,K,r,lx,k1-1),1) * qn_vec # speciation event - } - cp <- check_probs(loglik,qn_vec[1:lx],verbose) - loglik <- cp[[1]] - qn_vec[1:lx] <- cp[[2]] - } + loglik = loglik + (cond != 3 | soc == 1) * log(qn_vec[1 + (cond != 3) * missnumspec]) - lgamma(S + missnumspec + 1) + lgamma(S + 1) + lgamma(missnumspec + 1) + + logliknorm = 0 + if(cond == 1 | cond == 2) { + probsn = rep(0, lx) + probsn[1] = 1 # change if other species at stem or crown age + k = soc + t1 = brts[1] + t2 = brts[S + 2 - soc] + y = dd_integrate( + initprobs = probsn, + tvec = c(t1,t2), + rhs_func = rhs_func_name, + pars = c(pars1,k,ddep), + rtol = reltol, + atol = abstol, + method = methode + ) + probsn = y[2, 2:(lx + 1)] + if(soc == 1) { + aux = 1:lx } - if(qn_vec[1 + missnumspec] <= 0 | loglik == -Inf | is.na(loglik) | is.nan(loglik)) - { - if(verbose) cat('Probabilities smaller than 0 or other numerical problems are encountered in final result.\n') - loglik = -Inf - } else { - loglik = loglik + (cond != 3 | soc == 1) * log(qn_vec[1 + (cond != 3) * missnumspec]) - lgamma(S + missnumspec + 1) + lgamma(S + 1) + lgamma(missnumspec + 1) - - logliknorm = 0 - if(cond == 1 | cond == 2) { - probsn = rep(0, lx) - probsn[1] = 1 # change if other species at stem or crown age - k = soc - t1 = brts[1] - t2 = brts[S + 2 - soc] - y = dd_integrate( - initprobs = probsn, - tvec = c(t1,t2), - rhs_func = rhs_func_name, - pars = c(pars1,k,ddep), - rtol = reltol, - atol = abstol, - method = methode - ) - probsn = y[2, 2:(lx + 1)] - if(soc == 1) { - aux = 1:lx - } - if(soc == 2) { - aux = (2:(lx + 1)) * (3:(lx + 2)) / 6 - } - probsc = probsn / aux - cp <- check_probs(logliknorm,probsc,verbose) - logliknorm <- cp[[1]] - probsc <- cp[[2]] - if (cond == 1) { - logliknorm = logliknorm + log(sum(probsc)) - } - if (cond == 2) { - logliknorm = logliknorm + log(probsc[S + missnumspec - soc + 1]) - } - } - if (cond == 3) { - probsn = rep(0, lx + 1) - probsn[S + missnumspec + 1] = 1 - TT = max(1, 1 / abs(la - mu)) * 1E+10 * max(abs(brts)) # make this more efficient later - y = dd_integrate( - initprobs = probsn, - tvec = c(0, TT), - rhs_func = rhs_func_name, - pars = c(pars1, 0, ddep), - rtol = reltol, - atol = abstol, - method = methode - ) - logliknorm = log(y[2,lx + 2]) - if(soc == 2) { - probsn = rep(0,lx + 1) - probsn[1:lx] = qn_vec[1:lx] - probsn = c(flavec(ddep, la, mu, K, r, lx, 1), 1) * probsn # speciation event - y = dd_integrate( - initprobs = probsn, - tvec = c(max(abs(brts)), TT), - rhs_func = rhs_func_name, - pars = c(pars1,1,ddep), - rtol = reltol, - atol = abstol, - method = methode - ) - logliknorm = logliknorm - log(y[2,lx + 2]) - } - } - if(is.na(logliknorm) | is.nan(logliknorm) | logliknorm == Inf) { - if(verbose) cat('The normalization did not yield a number.\n') - loglik = -Inf - } else { - loglik = loglik - logliknorm - } + if(soc == 2) { + aux = (2:(lx + 1)) * (3:(lx + 2)) / 6 + } + probsc = probsn / aux + cp <- check_probs(logliknorm,probsc,verbose) + logliknorm <- cp[[1]] + probsc <- cp[[2]] + if (cond == 1) { + logliknorm = logliknorm + log(sum(probsc)) } + if (cond == 2) { + logliknorm = logliknorm + log(probsc[S + missnumspec - soc + 1]) + } + } + if (cond == 3) { + probsn = rep(0, lx + 1) + probsn[S + missnumspec + 1] = 1 + TT = max(1, 1 / abs(la - mu)) * 1E+10 * max(abs(brts)) # make this more efficient later + y = dd_integrate( + initprobs = probsn, + tvec = c(0, TT), + rhs_func = rhs_func_name, + pars = c(pars1, 0, ddep), + rtol = reltol, + atol = abstol, + method = methode + ) + logliknorm = log(y[2,lx + 2]) + if(soc == 2) { + probsn = rep(0,lx + 1) + probsn[1:lx] = qn_vec[1:lx] + probsn = c(flavec(ddep, la, mu, K, r, lx, 1), 1) * probsn # speciation event + y = dd_integrate( + initprobs = probsn, + tvec = c(max(abs(brts)), TT), + rhs_func = rhs_func_name, + pars = c(pars1,1,ddep), + rtol = reltol, + atol = abstol, + method = methode + ) + logliknorm = logliknorm - log(y[2,lx + 2]) + } + } + if(is.na(logliknorm) | is.nan(logliknorm) | logliknorm == Inf) { + if(verbose) cat('The normalization did not yield a number.\n') + loglik = -Inf + } else { + loglik = loglik - logliknorm } } } - if (verbose) { - s1 = sprintf('Parameters: %f %f %f',pars1[1],pars1[2],pars1[3]) - if (both_rates_vary(ddep)) { - s1 = sprintf('%s %f',s1,pars1[4]) - } - s2 = sprintf(', Loglikelihood: %f',loglik) - cat(s1,s2,"\n",sep = "") - utils::flush.console() + } + if (verbose) { + s1 = sprintf('Parameters: %f %f %f',pars1[1],pars1[2],pars1[3]) + if (both_rates_vary(ddep)) { + s1 = sprintf('%s %f',s1,pars1[4]) } + s2 = sprintf(', Loglikelihood: %f',loglik) + cat(s1,s2,"\n",sep = "") + utils::flush.console() } loglik = as.numeric(loglik) if(is.nan(loglik) | is.na(loglik)) { @@ -362,7 +354,7 @@ dd_loglik2 = function(pars1,pars2,brts,missnumspec) if (ddep > 5) { stop("This DD model is not implemented for the analytical method yet.") } - cond = pars2[3] + cond = pars2[3] btorph = pars2[4] verbose <- pars2[5] soc = pars2[6] diff --git a/man/dd_loglik.Rd b/man/dd_loglik.Rd index 356eea6..81e9e44 100644 --- a/man/dd_loglik.Rd +++ b/man/dd_loglik.Rd @@ -4,7 +4,15 @@ \alias{dd_loglik} \title{Loglikelihood for diversity-dependent diversification models} \usage{ -dd_loglik(pars1, pars2, brts, missnumspec, methode = "analytical") +dd_loglik( + pars1, + pars2, + brts, + missnumspec = 0, + methode = "analytical", + rhs_func_name = ifelse(pars2[3] == 3, "dd_loglik_bw_rhs_FORTRAN", + "dd_loglik_rhs_FORTRAN") +) } \arguments{ \item{pars1}{Vector of parameters: From 76ffbfafe5445d2dbb2d7970f202c5ce03196252 Mon Sep 17 00:00:00 2001 From: Theo Pannetier Date: Thu, 8 Apr 2021 21:51:40 +0200 Subject: [PATCH 19/49] test input parameter values --- tests/testthat/test-optimizer.R | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/tests/testthat/test-optimizer.R b/tests/testthat/test-optimizer.R index dfec6b3..c6fe533 100644 --- a/tests/testthat/test-optimizer.R +++ b/tests/testthat/test-optimizer.R @@ -4,15 +4,15 @@ test_that("optimizer works", { brts <- 1:10 initparsopt <- c(0.3,0.05,12) idparsopt <- 1:3 - res_simplex <- DDD::dd_ML(brts = brts, + res_simplex <- dd_ML(brts = brts, initparsopt = initparsopt, idparsopt = idparsopt, optimmethod = 'simplex') - res_subplex <- DDD::dd_ML(brts = brts, + res_subplex <- dd_ML(brts = brts, initparsopt = initparsopt, idparsopt = idparsopt, optimmethod = 'subplex') - #res_nloptr <- DDD::dd_ML(brts = brts, + #res_nloptr <- dd_ML(brts = brts, # initparsopt = initparsopt, # idparsopt = idparsopt, # optimmethod = 'NLOPT_LN_SBPLX') From b6db7c1b5ffa7d24938f119e226e7ac84dc18429 Mon Sep 17 00:00:00 2001 From: Theo Pannetier Date: Sat, 10 Apr 2021 14:32:31 +0200 Subject: [PATCH 20/49] test ddmodel parameters --- tests/testthat/test_pars_dd_loglik.R | 83 ++++++++++++++++++++++++++++ 1 file changed, 83 insertions(+) create mode 100644 tests/testthat/test_pars_dd_loglik.R diff --git a/tests/testthat/test_pars_dd_loglik.R b/tests/testthat/test_pars_dd_loglik.R new file mode 100644 index 0000000..113bd5e --- /dev/null +++ b/tests/testthat/test_pars_dd_loglik.R @@ -0,0 +1,83 @@ + +# Case tree +set.seed(26071948) # jjsepkoski +phylo <- dd_sim( + pars = c(0.8, 0.1, 20, 1), + age = 20, + ddmodel = 5 +)$tes +brts <- ape::branching.times(phylo) + +# Test function +run_dd_loglik <- function(ddmodel, lambda_0 = 0.8, mu_0 = 0.1, K = 20, r = 1, verbose = FALSE) { + if (both_rates_vary(ddmodel)) { + pars1 <- c(lambda_0, mu_0, K, r) + } else { + pars1 <- c(lambda_0, mu_0, K) + } + pars2 <- c("lx" = 50, "ddmodel" = ddmodel, "cond" = 1, "btorph" = 0, "verbose" = verbose, "soc" = 2) + dd_loglik( + pars1 = pars1, + pars2 = pars2, + brts = brts, # defined above + missnumspec = 0, + methode = "ode45", + rhs_func_name = "dd_loglik_rhs" # so only numerical method + ) +} + +test_that("all DD models return a likelihood", { + expect_silent(logL_dd1 <- run_dd_loglik(ddmodel = 1)) + expect_true(logL_dd1 < 0 && is.finite(logL_dd1)) + expect_silent(logL_dd2 <- run_dd_loglik(ddmodel = 2)) + expect_true(logL_dd2 < 0 && is.finite(logL_dd2)) + expect_silent(logL_dd3 <- run_dd_loglik(ddmodel = 3)) + expect_true(logL_dd3 < 0 && is.finite(logL_dd3)) + expect_silent(logL_dd4 <- run_dd_loglik(ddmodel = 4)) + expect_true(logL_dd4 < 0 && is.finite(logL_dd4)) + expect_silent(logL_dd5 <- run_dd_loglik(ddmodel = 5)) + expect_true(logL_dd5 < 0 && is.finite(logL_dd5)) + expect_silent(logL_dd6 <- run_dd_loglik(ddmodel = 6)) + expect_true(logL_dd6 < 0 && is.finite(logL_dd6)) + expect_silent(logL_dd7 <- run_dd_loglik(ddmodel = 7)) + expect_true(logL_dd7 < 7 && is.finite(logL_dd7)) + expect_silent(logL_dd8 <- run_dd_loglik(ddmodel = 8)) + expect_true(logL_dd8 < 0 && is.finite(logL_dd8)) + expect_silent(logL_dd9 <- run_dd_loglik(ddmodel = 9)) + expect_true(logL_dd9 < 0 && is.finite(logL_dd9)) + expect_silent(logL_dd10 <- run_dd_loglik(ddmodel = 10)) + expect_true(logL_dd10 < 0 && is.finite(logL_dd10)) + expect_silent(logL_dd11 <- run_dd_loglik(ddmodel = 11)) + expect_true(logL_dd11 < 0 && is.finite(logL_dd11)) + expect_silent(logL_dd12 <- run_dd_loglik(ddmodel = 12)) + expect_true(logL_dd12 < 0 && is.finite(logL_dd12)) + expect_silent(logL_dd13 <- run_dd_loglik(ddmodel = 13)) + expect_true(logL_dd13 < 0 && is.finite(logL_dd13)) +}) + +test_that("ddmodel = 1 ok", { + expect_equal(run_dd_loglik(ddmodel = 1, lambda_0 = 500), -Inf) # also -Inf with 1000 + # run_dd_loglik(ddmodel = 1, lambda_0 = 300) NAs / NaNs introduced, not solved + # expect_equal(run_dd_loglik(ddmodel = 1, lambda_0 = 5000), -Inf) # bug! # high lambda approximation + # Negative parameters are not allowed + expect_equal(run_dd_loglik(ddmodel = 1, lambda_0 = -1), -Inf) + # lambda0 = mu0 not allowed + expect_equal(run_dd_loglik(ddmodel = 1, lambda_0 = 0.8, mu_0 = 0.8), -Inf) + expect_equal(run_dd_loglik(ddmodel = 1, lambda_0 = 0, mu_0 = 0, K = 0), -Inf) + # Linear-DD speciation must have K' > N + expect_equal(run_dd_loglik(ddmodel = 1, K = 14), -Inf) + expect_equal(run_dd_loglik(ddmodel = 5, K = 7), -Inf) + # Other values of K < N but respecting K' > N should return a result + expect_silent(run_dd_loglik(ddmodel = 5, K = 8)) + # Exponential-DD extinction must have mu0 > 0 or result is NaN + expect_equal(run_dd_loglik(ddmodel = 4, mu_0 = 0), -Inf) + expect_equal(run_dd_loglik(ddmodel = 6, mu_0 = 0), -Inf) + expect_equal(run_dd_loglik(ddmodel = 7, mu_0 = 0), -Inf) + # Exponential-DD speciation must have either mu0 > 0 or r > 0 or result is NaN + expect_equal(run_dd_loglik(ddmodel = 2, mu_0 = 0), -Inf) + expect_equal(run_dd_loglik(ddmodel = 8, mu_0 = 0, r = 0), -Inf) + # Exponential(alternative)-DD extinction must have mu0 > 0 or result is NaN + expect_equal(run_dd_loglik(ddmodel = 10, mu_0 = 0), -Inf) + expect_equal(run_dd_loglik(ddmodel = 11, mu_0 = 0), -Inf) + expect_equal(run_dd_loglik(ddmodel = 12, mu_0 = 0), -Inf) +}) \ No newline at end of file From 5f699de8bf076b5e39f2e5460341fec9022bc6c6 Mon Sep 17 00:00:00 2001 From: Theo Pannetier Date: Thu, 15 Apr 2021 14:08:17 +0200 Subject: [PATCH 21/49] interrupt ODE integration if any prob is NA; cleaner verbose --- R/dd_loglik.R | 19 ++++++++++--------- R/dd_loglik_M.R | 2 +- 2 files changed, 11 insertions(+), 10 deletions(-) diff --git a/R/dd_loglik.R b/R/dd_loglik.R index 10ec6ce..b0d95ed 100644 --- a/R/dd_loglik.R +++ b/R/dd_loglik.R @@ -164,6 +164,13 @@ dd_loglik1 = function(pars1,pars2,brts,missnumspec,methode = 'lsoda',rhs_func_na r <- ifelse(both_rates_vary(ddep), pars1[4], 0) Kprime <- get_Kprime(ddep, pars1) is_speciation_linear <- ddep %in% c(1, 1.3, 5, 6, 11) + if (verbose) { + if (both_rates_vary(ddep)) { + cat("loglik for la0 =", la, "mu0 =", mu, "K =", K, "r =", r, "\n") + } else { + cat("loglik for la0 =", la, "mu0 =", mu, "K =", K, "\n") + } + } lx = min(max(1 + missnumspec, 1 + Kprime), ceiling(pars2[1])) @@ -224,6 +231,7 @@ dd_loglik1 = function(pars1,pars2,brts,missnumspec,methode = 'lsoda',rhs_func_na cp <- check_probs(loglik, qn_vec, verbose) loglik <- cp[[1]] qn_vec <- cp[[2]] + if (loglik == -Inf | is.na(loglik) | is.nan(loglik)) break() } } else { # cond == 3 qn_vec = rep(0,lx + 1) @@ -246,6 +254,7 @@ dd_loglik1 = function(pars1,pars2,brts,missnumspec,methode = 'lsoda',rhs_func_na cp <- check_probs(loglik,qn_vec[1:lx],verbose) loglik <- cp[[1]] qn_vec[1:lx] <- cp[[2]] + if (loglik == -Inf | is.na(loglik) | is.nan(loglik)) break() } } if (qn_vec[1 + missnumspec] <= 0 | loglik == -Inf | is.na(loglik) | is.nan(loglik)) { @@ -327,15 +336,7 @@ dd_loglik1 = function(pars1,pars2,brts,missnumspec,methode = 'lsoda',rhs_func_na } } } - if (verbose) { - s1 = sprintf('Parameters: %f %f %f',pars1[1],pars1[2],pars1[3]) - if (both_rates_vary(ddep)) { - s1 = sprintf('%s %f',s1,pars1[4]) - } - s2 = sprintf(', Loglikelihood: %f',loglik) - cat(s1,s2,"\n",sep = "") - utils::flush.console() - } + if (verbose) cat("Loglikelihood =", loglik, "\n\n") loglik = as.numeric(loglik) if(is.nan(loglik) | is.na(loglik)) { loglik = -Inf diff --git a/R/dd_loglik_M.R b/R/dd_loglik_M.R index 13ac9cb..2db37a1 100644 --- a/R/dd_loglik_M.R +++ b/R/dd_loglik_M.R @@ -5,7 +5,7 @@ lambdamu = function(n,pars,ddep) mu = pars[2] K = pars[3] r = pars[4] - alpha <- ifelse(r == Inf, 1, r / (1 + r)) # else r/(1+r) can be NaN + alpha <- ifelse(r == Inf, 1, r / (1 + r)) # else r/(1+r) is NaN n0 = (ddep == 2 | ddep == 4) if(ddep == 1) { lavec = pmax(0, la - (la - mu) * n / K) From e5c9faaec1e5924f642a86839d1ac650f59edeb7 Mon Sep 17 00:00:00 2001 From: Theo Pannetier Date: Fri, 23 Apr 2021 14:13:26 +0200 Subject: [PATCH 22/49] fix misspecified model number --- R/dd_loglik.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/dd_loglik.R b/R/dd_loglik.R index b0d95ed..c3b700c 100644 --- a/R/dd_loglik.R +++ b/R/dd_loglik.R @@ -190,7 +190,7 @@ dd_loglik1 = function(pars1,pars2,brts,missnumspec,methode = 'lsoda',rhs_func_na } else if (la == 0) { if (verbose) cat('la0 cannot be zero.\n') loglik = -Inf - } else if (ddep %in% c(2, 2.1, 2.1, 4, 6, 7, 10:12) && mu == 0) { + } else if (ddep %in% c(2, 2.1, 2.2, 4, 6, 7, 10:12) && mu == 0) { if (verbose) cat('mu0 cannot be exactly zero for this model.\n') loglik = -Inf } else if (ddep == 8 && mu == 0 && r == 0) { From 367334daf0437f8a2cabd24aae6767fdfeaa59c8 Mon Sep 17 00:00:00 2001 From: Theo Pannetier Date: Tue, 27 Apr 2021 16:02:12 +0200 Subject: [PATCH 23/49] fix both_rates_vary doc --- NAMESPACE | 1 + R/dd_utils.R | 7 +++---- man/both_rates_vary.Rd | 12 +++++++----- 3 files changed, 11 insertions(+), 9 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index 906b361..9ecdfe1 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -4,6 +4,7 @@ export(L2brts) export(L2phylo) export(bd_ML) export(bd_loglik) +export(both_rates_vary) export(brts2phylo) export(conv) export(dd_KI_ML) diff --git a/R/dd_utils.R b/R/dd_utils.R index eb1457a..8791210 100644 --- a/R/dd_utils.R +++ b/R/dd_utils.R @@ -889,10 +889,9 @@ rng_respecting_sample <- function(x, size, replace, prob) { #' @param ddmodel a character or integer specifying a DD model, as described in #' dd_loglik() and dd_ML() documentation #' -#' @return TRUE if both speciation and extinction rates vary with N, FALSE otherwise -#' @export -#' @author Theo Pannetier -#' +#' @return TRUE if both speciation and extinction rates vary with N, FALSE otherwise +#' @author Theo Pannetier +#' @export both_rates_vary <- function(ddmodel) { return(ddmodel %in% c(5:8, 11:13)) } diff --git a/man/both_rates_vary.Rd b/man/both_rates_vary.Rd index 6ac127f..620bea2 100644 --- a/man/both_rates_vary.Rd +++ b/man/both_rates_vary.Rd @@ -8,12 +8,14 @@ both_rates_vary(ddmodel) } \arguments{ \item{ddmodel}{a character or integer specifying a DD model, as described in -dd_loglik() and dd_ML() documentation - -@return TRUE if both speciation and extinction rates vary with N, FALSE otherwise -@export -@author Theo Pannetier} +dd_loglik() and dd_ML() documentation} +} +\value{ +TRUE if both speciation and extinction rates vary with N, FALSE otherwise } \description{ Evaluate whether both speciation rates vary in specified DD model } +\author{ +Theo Pannetier +} From cad6a9eed062021192bac7eb4fd5f546368a9108 Mon Sep 17 00:00:00 2001 From: Theo Pannetier Date: Tue, 29 Jun 2021 16:29:32 +0200 Subject: [PATCH 24/49] update doc to include new DD models --- R/dd_ML.R | 35 ++++++++++--- R/dd_loglik.R | 75 ++++++++++++++++++---------- R/dd_loglik_M.R | 74 +++++++++++++++++++-------- man/dd_ML.Rd | 28 +++++++++-- man/dd_loglik.Rd | 52 +++++++++++-------- tests/testthat/test_pars_dd_loglik.R | 6 +-- 6 files changed, 186 insertions(+), 84 deletions(-) diff --git a/R/dd_ML.R b/R/dd_ML.R index d268153..00b599e 100644 --- a/R/dd_ML.R +++ b/R/dd_ML.R @@ -15,8 +15,6 @@ parsfixdefault = function(ddmodel, brts, missnumspec, idparsopt) { } } - - #' Maximization of the loglikelihood under a diversity-dependent #' diversification model #' @@ -59,19 +57,38 @@ parsfixdefault = function(ddmodel, brts, missnumspec, idparsopt) { #' \code{ddmodel == 1.5} : positive and negative dependence in speciation rate #' with parameter K' (= diversity where speciation = 0); lambda = lambda0 * #' S/K' * (1 - S/K') where S is species richness\cr -#' \code{ddmodel == 2} : exponential dependence in speciation rate with parameter +#' \code{ddmodel == 2} : exponential dependence (power function) in speciation rate with parameter #' K (= diversity where speciation = extinction)\cr -#' \code{ddmodel == 2.1} : variant of exponential dependence in speciation rate +#' \code{ddmodel == 2.1} : variant of exponential dependence (power function) in speciation rate #' with offset at infinity\cr #' \code{ddmodel == 2.2} : 1/n dependence in speciation rate\cr -#' \code{ddmodel == 2.3} : exponential dependence in speciation rate with parameter x (= +#' \code{ddmodel == 2.3} : exponential dependence (power function) in speciation rate with parameter x (= #' exponent)\cr #' \code{ddmodel == 3} : linear dependence in extinction rate \cr -#' \code{ddmodel == 4} : exponential dependence in extinction rate \cr +#' \code{ddmodel == 4} : exponential dependence (power function) in extinction rate \cr #' \code{ddmodel == 4.1} : variant of exponential dependence in extinction rate #' with offset at infinity \cr #' \code{ddmodel == 4.2} : 1/n dependence in extinction rate with offset at infinity \cr \code{ddmodel == 5} : linear #' dependence in speciation and extinction rate \cr +#' \code{ddmodel == 5} : linear dependence in speciation and +#' extinction rate \cr +#' \code{ddmodel == 6} : linear dependence in speciation rate, exponential +#' dependence (power function) in extinction rate \cr +#' \code{ddmodel == 7} : exponential dependence (power function) in speciation +#' and extinction rate \cr +#' \code{ddmodel == 8} : exponential dependence (power function) in speciation rate, +#' linear dependence in extinction rate \cr +#' \code{ddmodel == 9} : exponential dependence (exponential function) in speciation, +#' constant-rate extinction \cr +#' \code{ddmodel == 10} : constant-rate speciation, exponential dependence +#' (exponential function) in extinction \cr +#' \code{ddmodel == 11} : linear dependence in speciation, exponential +#' dependence (exponential function) in extinction\cr +#' \code{ddmodel == 12} : exponential dependence (exponential function) in +#' speciation and extinction\cr +#' \code{ddmodel == 13} : exponential dependence (exponential function) in +#' speciation, linear dependence in extinction \cr +#' #' @param missnumspec The number of species that are in the clade but missing #' in the phylogeny #' @param cond Conditioning: \cr @@ -159,6 +176,12 @@ dd_ML = function( output_error <- data.frame(lambda = -1,mu = -1,K = -1, loglik = -1, df = -1, conv = -1) } + if (ddmodel > 5) { + if (method == "analytical" || cond == 3) { + stop("Sorry, ddmodel options > 5 have not been developed for method = \"analytical\" or cond = 3.") + } + } + brts = sort(abs(as.numeric(brts)),decreasing = TRUE) if (is.numeric(brts) == FALSE) { cat("The branching times should be numeric.\n") diff --git a/R/dd_loglik.R b/R/dd_loglik.R index c3b700c..73bf373 100644 --- a/R/dd_loglik.R +++ b/R/dd_loglik.R @@ -10,15 +10,32 @@ # . ddep == 1 : linear dependence in speciation rate with parameter K # . ddep == 1.3 : linear dependence in speciation rate with parameter K' # . ddep == 1.4 : positive and negative linear diversity-dependence in speciation rate with parameter K' -# . ddep == 2 : exponential dependence in speciation rate +# . ddep == 2 : exponential dependence (power function) in speciation rate # . ddep == 2.1: variant with offset at infinity # . ddep == 2.2: 1/n dependence in speciation rate -# . ddep == 2.3: exponential dependence in speciation rate with parameter x +# . ddep == 2.3: exponential dependence (power function) in speciation rate with parameter x # . ddep == 3 : linear dependence in extinction rate -# . ddep == 4 : exponential dependence in extinction rate +# . ddep == 4 : exponential dependence (power function) in extinction rate # . ddep == 4.1: variant with offset at infinity # . ddep == 4.2: 1/n dependence in speciation rate # . ddep == 5 : linear dependence in speciation and extinction rate +# . ddep == 6 : linear dependence in speciation, exponential dependence +# (power function) in extinction rate +# . ddep == 7 : exponential dependence (power function) in speciation +# and extinction rate +# . ddep == 8 : : exponential dependence (power function) in speciation rate, +# linear dependence in extinction rate +# . ddep == 9 : : exponential dependence (exponential function) in speciation, +# constant-rate extinction +# . ddep == 10 : : constant-rate speciation, exponential dependence +# (exponential function) in extinction +# . ddep == 11 : : linear dependence in speciation, exponential +# dependence (exponential function) in extinction +# . ddep == 12 : : exponential dependence (exponential function) in +# speciation and extinction +# . ddep == 13 : : exponential dependence (exponential function) in +# speciation, linear dependence in extinction + # - pars2[3] = cond = conditioning # . cond == 0 : conditioning on stem or crown age # . cond == 1 : conditioning on stem or crown age and non-extinction of the phylogeny @@ -59,11 +76,9 @@ dd_loglik_test = function(pars1,pars2,brts,missnumspec,methode = 'analytical',rh #' \cr \cr \code{pars2[1]} sets the #' maximum number of species for which a probability must be computed. This #' must be larger than 1 + missnumspec + length(brts). -#' \cr \cr \code{pars2[2]} -#' sets the model of diversity-dependence: -#' \cr - \code{pars2[2] == 1} linear -#' dependence in speciation rate with parameter K (= diversity where speciation -#' = extinction) +#' \cr \cr \code{pars2[2]} sets the model of diversity-dependence: +#' \cr - \code{pars2[2] == 1} linear dependence in speciation rate with +#' parameter K (= diversity where speciation = extinction) #' \cr - \code{pars2[2] == 1.3} linear dependence in speciation #' rate with parameter K' (= diversity where speciation = 0) #' \cr - \code{pars2[2] == 1.4} : positive diversity-dependence in speciation rate @@ -72,28 +87,38 @@ dd_loglik_test = function(pars1,pars2,brts,missnumspec,methode = 'analytical',rh #' \cr - \code{pars2[2] == 1.5} : positive and negative diversity-dependence in #' speciation rate with parameter K' (= diversity where speciation = 0); lambda #' = lambda0 * S/K' * (1 - S/K') where S is species richness -#' \cr - \code{pars2[2] == 2} exponential dependence in speciation rate with +#' \cr - \code{pars2[2] == 2} exponential dependence (power function) in speciation rate with #' parameter K (= diversity where speciation = extinction) #' \cr - \code{pars2[2] -#' == 2.1} variant of exponential dependence in speciation rate with offset at +#' == 2.1} variant of exponential dependence (power function) in speciation rate with offset at #' infinity #' \cr - \code{pars2[2] == 2.2} 1/n dependence in speciation rate -#' \cr - \code{pars2[2] == 2.3} exponential dependence in speciation rate with +#' \cr - \code{pars2[2] == 2.3} exponential dependence (power function) in speciation rate with #' parameter x (= exponent) -#' \cr - \code{pars2[2] == 3} linear dependence in -#' extinction rate -#' \cr - \code{pars2[2] == 4} exponential dependence in -#' extinction rate -#' \cr - \code{pars2[2] == 4.1} variant of exponential -#' dependence in extinction rate with offset at infinity -#' \cr - \code{pars2[2] == -#' 4.2} 1/n dependence in extinction rate -#' \cr - \code{pars2[2] == 5} linear -#' dependence in speciation and extinction rate -#' \cr \cr \code{pars2[3]} sets -#' the conditioning: -#' \cr - \code{pars2[3] == 0} conditioning on stem or crown -#' age +#' \cr - \code{pars2[2] == 3} linear dependence in extinction rate +#' \cr - \code{pars2[2] == 4} exponential dependence (power function) in extinction rate +#' \cr - \code{pars2[2] == 4.1} variant of exponential dependence (power function) in extinction +#' rate with offset at infinity +#' \cr - \code{pars2[2] == 4.2} 1/n dependence in extinction rate +#' \cr - \code{pars2[2] == 5} linear dependence in speciation and extinction rate +#' \cr - \code{pars2[2] == 6} linear dependence in speciation rate, exponential +#' dependence (power function) in extinction rate \cr +#' \cr - \code{pars2[2] == 7} exponential dependence (power function) in speciation +#' and extinction rate \cr +#' \cr - \code{pars2[2] == 8} exponential dependence (power function) in speciation rate, +#' linear dependence in extinction rate \cr +#' \cr - \code{pars2[2] == 9} exponential dependence (exponential function) in speciation, +#' constant-rate extinction \cr +#' \cr - \code{pars2[2] == 10} constant-rate speciation, exponential dependence +#' (exponential function) in extinction \cr +#' \cr - \code{pars2[2] == 11} linear dependence in speciation, exponential +#' dependence (exponential function) in extinction\cr +#' \cr - \code{pars2[2] == 12} exponential dependence (exponential function) in +#' speciation and extinction\cr +#' \cr - \code{pars2[2] == 13} exponential dependence (exponential function) in +#' speciation, linear dependence in extinction \cr +#' \cr \cr \code{pars2[3]} sets the conditioning: +#' \cr - \code{pars2[3] == 0} conditioning on stem or crown age #' \cr - \code{pars2[3] == 1} conditioning on stem or crown age and #' non-extinction of the phylogeny #' \cr - \code{pars2[3] == 2} conditioning on diff --git a/R/dd_loglik_M.R b/R/dd_loglik_M.R index 2db37a1..d76847a 100644 --- a/R/dd_loglik_M.R +++ b/R/dd_loglik_M.R @@ -8,55 +8,85 @@ lambdamu = function(n,pars,ddep) alpha <- ifelse(r == Inf, 1, r / (1 + r)) # else r/(1+r) is NaN n0 = (ddep == 2 | ddep == 4) if(ddep == 1) { - lavec = pmax(0, la - (la - mu) * n / K) - muvec = rep(mu, lnn) + # linear DD on speciation (K = equilibrium diversity) + # constant-rate extinction + lavec = pmax(0, la - (la - mu) * n / K) + muvec = rep(mu, lnn) } else if(ddep == 1.3) { - lavec = pmax(0, la * (1 - n / K)) - muvec = rep(mu, lnn) + # linear DD on speciation (K = carrying capacity) + # constant-rate extinction + lavec = pmax(0, la * (1 - n / K)) + muvec = rep(mu, lnn) } else if(ddep == 2 | ddep == 2.1 | ddep == 2.2) { - y = -(log(la / mu) / log(K + n0)) ^ (ddep != 2.2) - lavec = pmax(0, la * (n + n0) ^ y) - muvec = rep(mu, lnn) + # "exponential" DD on speciation (power function) + # constant-rate extinction + y = -(log(la / mu) / log(K + n0)) ^ (ddep != 2.2) + lavec = pmax(0, la * (n + n0) ^ y) + muvec = rep(mu, lnn) } else if(ddep == 2.3) { - y = -K - lavec = pmax(0, la * (n + n0) ^ y) - muvec = rep(mu, lnn) + # "exponential" DD on speciation (power function) + # constant-rate extinction + y = -K + lavec = pmax(0, la * (n + n0) ^ y) + muvec = rep(mu, lnn) } else if(ddep == 3) { - lavec = rep(la, lnn) - muvec = mu + (la - mu) * n/K + # constant-rate speciation + # linear DD on extinction + lavec = rep(la, lnn) + muvec = mu + (la - mu) * n/K } else if (ddep == 4 | ddep == 4.1 | ddep == 4.2) { - y = (log(la / mu) / log(K + n0)) ^ (ddep != 4.2) - lavec = rep(la, lnn) - muvec = mu * (n + n0) ^ y + # constant-rate speciation + # "exponential" DD on extinction (power function) + y = (log(la / mu) / log(K + n0)) ^ (ddep != 4.2) + lavec = rep(la, lnn) + muvec = mu * (n + n0) ^ y } else if (ddep == 5) { - lavec = pmax(0, la - (1 - alpha) * (la - mu) * n / K) - muvec = mu + alpha * (la - mu) * n / K + # linear DD on speciation + # linear DD on extinction + lavec = pmax(0, la - (1 - alpha) * (la - mu) * n / K) + muvec = mu + alpha * (la - mu) * n / K } else if (ddep == 6) { + # linear DD on speciation + # "exponential" DD on extinction (power function) y = log(1 + alpha * (la - mu) / mu) / log(K) lavec = pmax(0, la - (1 - alpha) * (la - mu) * n / K) muvec = mu * n ^ y } else if (ddep == 7) { + # "exponential" DD on speciation (power function) + # "exponential" DD on extinction (power function) y1 = -log(la / (alpha * (la - mu) + mu)) / log(K) y2 = log(1 + alpha * (la - mu) / mu) / log(K) lavec = pmax(0, la * n ^ y1) muvec = mu * n ^ y2 } else if (ddep == 8) { + # "exponential" DD on speciation (power function) + # linear DD on extinction y = -log(la / (alpha * (la - mu) + mu)) / log(K) lavec = pmax(0, la * n ^ y) muvec = mu + alpha * (la - mu) / K * n } else if (ddep == 9) { + # exponential DD on speciation (exponential function) + # constant-rate extinction lavec = pmax(0, la * (mu / la) ^ (n / K)) muvec = rep(mu, lnn) } else if (ddep == 10) { + # constant-rate speciation + # exponential DD on extinction (exponential function) lavec = rep(la, lnn) muvec = mu * (la / mu) ^ (n / K) } else if (ddep == 11) { + # linear DD on speciation + # exponential DD on extinction (exponential function) lavec = pmax(0, la - (1 - alpha) * (la - mu) * n / K) muvec = mu * (1 + alpha * (la - mu) / mu) ^ (n / K) } else if (ddep == 12) { + # exponential DD on speciation (exponential function) + # exponential DD on extinction (exponential function) lavec = pmax(0, la * ((alpha * (la - mu) + mu) / la) ^ (n / K)) muvec = mu * (1 + alpha * (la - mu) / mu) ^ (n / K) } else if (ddep == 13) { + # exponential DD on speciation (exponential function) + # linear DD on extinction lavec = pmax(0, la * ((alpha * (la - mu) + mu) / la) ^ (n / K)) muvec = mu + alpha * (la - mu) * n / K } @@ -81,21 +111,21 @@ changepars = function(pars) { if(length(pars) <= 3) { - sel = 1:2 + sel = 1:2 } else { - sel = c(1:2,4:min(length(pars),5)) + sel = c(1:2,4:min(length(pars),5)) } if(sum(pars[sel] == Inf) > 0) { - pars[which(pars[sel] == Inf)] = 1E+10 + pars[which(pars[sel] == Inf)] = 1E+10 } if(sum(pars[sel] == 0) > 0) { - pars[which(pars[sel] == 0)] = 1E-14 + pars[which(pars[sel] == 0)] = 1E-14 } if(sum(pars[sel] == 1) > 0) { - pars[which(pars[sel] == 1)] = pars[which(pars[sel] == 1)] - 1E-14 + pars[which(pars[sel] == 1)] = pars[which(pars[sel] == 1)] - 1E-14 } return(pars) } diff --git a/man/dd_ML.Rd b/man/dd_ML.Rd index 3a3ee90..0e5ff39 100644 --- a/man/dd_ML.Rd +++ b/man/dd_ML.Rd @@ -61,19 +61,37 @@ maximum); lambda = lambda0 * S/(S + K') where S is species richness\cr \code{ddmodel == 1.5} : positive and negative dependence in speciation rate with parameter K' (= diversity where speciation = 0); lambda = lambda0 * S/K' * (1 - S/K') where S is species richness\cr -\code{ddmodel == 2} : exponential dependence in speciation rate with parameter +\code{ddmodel == 2} : exponential dependence (power function) in speciation rate with parameter K (= diversity where speciation = extinction)\cr -\code{ddmodel == 2.1} : variant of exponential dependence in speciation rate +\code{ddmodel == 2.1} : variant of exponential dependence (power function) in speciation rate with offset at infinity\cr \code{ddmodel == 2.2} : 1/n dependence in speciation rate\cr -\code{ddmodel == 2.3} : exponential dependence in speciation rate with parameter x (= +\code{ddmodel == 2.3} : exponential dependence (power function) in speciation rate with parameter x (= exponent)\cr \code{ddmodel == 3} : linear dependence in extinction rate \cr -\code{ddmodel == 4} : exponential dependence in extinction rate \cr +\code{ddmodel == 4} : exponential dependence (power function) in extinction rate \cr \code{ddmodel == 4.1} : variant of exponential dependence in extinction rate with offset at infinity \cr \code{ddmodel == 4.2} : 1/n dependence in extinction rate with offset at infinity \cr \code{ddmodel == 5} : linear -dependence in speciation and extinction rate \cr} +dependence in speciation and extinction rate \cr +\code{ddmodel == 5} : linear dependence in speciation and +extinction rate \cr +\code{ddmodel == 6} : linear dependence in speciation rate, exponential +dependence (power function) in extinction rate \cr +\code{ddmodel == 7} : exponential dependence (power function) in speciation +and extinction rate \cr +\code{ddmodel == 8} : exponential dependence (power function) in speciation rate, +linear dependence in extinction rate \cr +\code{ddmodel == 9} : exponential dependence (exponential function) in speciation, +constant-rate extinction \cr +\code{ddmodel == 10} : constant-rate speciation, exponential dependence +(exponential function) in extinction \cr +\code{ddmodel == 11} : linear dependence in speciation, exponential +dependence (exponential function) in extinction\cr +\code{ddmodel == 12} : exponential dependence (exponential function) in +speciation and extinction\cr +\code{ddmodel == 13} : exponential dependence (exponential function) in +speciation, linear dependence in extinction \cr} \item{missnumspec}{The number of species that are in the clade but missing in the phylogeny} diff --git a/man/dd_loglik.Rd b/man/dd_loglik.Rd index 81e9e44..6329aac 100644 --- a/man/dd_loglik.Rd +++ b/man/dd_loglik.Rd @@ -26,11 +26,9 @@ rate) \cr \cr \code{pars2[1]} sets the maximum number of species for which a probability must be computed. This must be larger than 1 + missnumspec + length(brts). -\cr \cr \code{pars2[2]} -sets the model of diversity-dependence: -\cr - \code{pars2[2] == 1} linear -dependence in speciation rate with parameter K (= diversity where speciation -= extinction) +\cr \cr \code{pars2[2]} sets the model of diversity-dependence: +\cr - \code{pars2[2] == 1} linear dependence in speciation rate with +parameter K (= diversity where speciation = extinction) \cr - \code{pars2[2] == 1.3} linear dependence in speciation rate with parameter K' (= diversity where speciation = 0) \cr - \code{pars2[2] == 1.4} : positive diversity-dependence in speciation rate @@ -39,28 +37,38 @@ maximum); lambda = lambda0 * S/(S + K') where S is species richness \cr - \code{pars2[2] == 1.5} : positive and negative diversity-dependence in speciation rate with parameter K' (= diversity where speciation = 0); lambda = lambda0 * S/K' * (1 - S/K') where S is species richness -\cr - \code{pars2[2] == 2} exponential dependence in speciation rate with +\cr - \code{pars2[2] == 2} exponential dependence (power function) in speciation rate with parameter K (= diversity where speciation = extinction) \cr - \code{pars2[2] -== 2.1} variant of exponential dependence in speciation rate with offset at +== 2.1} variant of exponential dependence (power function) in speciation rate with offset at infinity \cr - \code{pars2[2] == 2.2} 1/n dependence in speciation rate -\cr - \code{pars2[2] == 2.3} exponential dependence in speciation rate with +\cr - \code{pars2[2] == 2.3} exponential dependence (power function) in speciation rate with parameter x (= exponent) -\cr - \code{pars2[2] == 3} linear dependence in -extinction rate -\cr - \code{pars2[2] == 4} exponential dependence in -extinction rate -\cr - \code{pars2[2] == 4.1} variant of exponential -dependence in extinction rate with offset at infinity -\cr - \code{pars2[2] == -4.2} 1/n dependence in extinction rate -\cr - \code{pars2[2] == 5} linear -dependence in speciation and extinction rate -\cr \cr \code{pars2[3]} sets -the conditioning: -\cr - \code{pars2[3] == 0} conditioning on stem or crown -age +\cr - \code{pars2[2] == 3} linear dependence in extinction rate +\cr - \code{pars2[2] == 4} exponential dependence (power function) in extinction rate +\cr - \code{pars2[2] == 4.1} variant of exponential dependence (power function) in extinction +rate with offset at infinity +\cr - \code{pars2[2] == 4.2} 1/n dependence in extinction rate +\cr - \code{pars2[2] == 5} linear dependence in speciation and extinction rate +\cr - \code{pars2[2] == 6} linear dependence in speciation rate, exponential +dependence (power function) in extinction rate \cr +\cr - \code{pars2[2] == 7} exponential dependence (power function) in speciation +and extinction rate \cr +\cr - \code{pars2[2] == 8} exponential dependence (power function) in speciation rate, +linear dependence in extinction rate \cr +\cr - \code{pars2[2] == 9} exponential dependence (exponential function) in speciation, +constant-rate extinction \cr +\cr - \code{pars2[2] == 10} constant-rate speciation, exponential dependence +(exponential function) in extinction \cr +\cr - \code{pars2[2] == 11} linear dependence in speciation, exponential +dependence (exponential function) in extinction\cr +\cr - \code{pars2[2] == 12} exponential dependence (exponential function) in +speciation and extinction\cr +\cr - \code{pars2[2] == 13} exponential dependence (exponential function) in +speciation, linear dependence in extinction \cr +\cr \cr \code{pars2[3]} sets the conditioning: +\cr - \code{pars2[3] == 0} conditioning on stem or crown age \cr - \code{pars2[3] == 1} conditioning on stem or crown age and non-extinction of the phylogeny \cr - \code{pars2[3] == 2} conditioning on diff --git a/tests/testthat/test_pars_dd_loglik.R b/tests/testthat/test_pars_dd_loglik.R index 113bd5e..6725f3b 100644 --- a/tests/testthat/test_pars_dd_loglik.R +++ b/tests/testthat/test_pars_dd_loglik.R @@ -1,4 +1,3 @@ - # Case tree set.seed(26071948) # jjsepkoski phylo <- dd_sim( @@ -56,9 +55,8 @@ test_that("all DD models return a likelihood", { }) test_that("ddmodel = 1 ok", { - expect_equal(run_dd_loglik(ddmodel = 1, lambda_0 = 500), -Inf) # also -Inf with 1000 - # run_dd_loglik(ddmodel = 1, lambda_0 = 300) NAs / NaNs introduced, not solved - # expect_equal(run_dd_loglik(ddmodel = 1, lambda_0 = 5000), -Inf) # bug! # high lambda approximation + # expect_equal(run_dd_loglik(ddmodel = 1, lambda_0 = 500,verbose = TRUE), -Inf) # also -Inf with 1000 + # run_dd_loglik(ddmodel = 1, lambda_0 = 300) # NAs / NaNs introduced, not solved # Negative parameters are not allowed expect_equal(run_dd_loglik(ddmodel = 1, lambda_0 = -1), -Inf) # lambda0 = mu0 not allowed From b25273f93eb03f217b3726eb947f58a1ef48027a Mon Sep 17 00:00:00 2001 From: Theo Pannetier Date: Wed, 30 Jun 2021 01:43:31 +0200 Subject: [PATCH 25/49] two new DD models mixing power and exponential functions --- R/dd_ML.R | 5 ++++- R/dd_loglik.R | 17 ++++++++++------- R/dd_loglik_M.R | 12 ++++++++++++ R/dd_loglik_rhs.R | 8 ++++++++ R/dd_sim.R | 8 ++++++++ man/dd_ML.Rd | 6 +++++- 6 files changed, 47 insertions(+), 9 deletions(-) diff --git a/R/dd_ML.R b/R/dd_ML.R index 00b599e..8d7e5e8 100644 --- a/R/dd_ML.R +++ b/R/dd_ML.R @@ -88,7 +88,10 @@ parsfixdefault = function(ddmodel, brts, missnumspec, idparsopt) { #' speciation and extinction\cr #' \code{ddmodel == 13} : exponential dependence (exponential function) in #' speciation, linear dependence in extinction \cr -#' +#' \code{ddmodel == 14} : exponential dependence (exponential function) in +#' speciation, exponential dependence (power function) in extinction \cr +#' \code{ddmodel == 15} : exponential dependence (power function) in +#' speciation, exponential dependence (exponential function) in extinction \cr #' @param missnumspec The number of species that are in the clade but missing #' in the phylogeny #' @param cond Conditioning: \cr diff --git a/R/dd_loglik.R b/R/dd_loglik.R index 73bf373..8977ec6 100644 --- a/R/dd_loglik.R +++ b/R/dd_loglik.R @@ -23,19 +23,22 @@ # (power function) in extinction rate # . ddep == 7 : exponential dependence (power function) in speciation # and extinction rate -# . ddep == 8 : : exponential dependence (power function) in speciation rate, +# . ddep == 8 : exponential dependence (power function) in speciation rate, # linear dependence in extinction rate -# . ddep == 9 : : exponential dependence (exponential function) in speciation, +# . ddep == 9 : exponential dependence (exponential function) in speciation, # constant-rate extinction -# . ddep == 10 : : constant-rate speciation, exponential dependence +# . ddep == 10 : constant-rate speciation, exponential dependence # (exponential function) in extinction -# . ddep == 11 : : linear dependence in speciation, exponential +# . ddep == 11 : linear dependence in speciation, exponential # dependence (exponential function) in extinction -# . ddep == 12 : : exponential dependence (exponential function) in +# . ddep == 12 : exponential dependence (exponential function) in # speciation and extinction -# . ddep == 13 : : exponential dependence (exponential function) in +# . ddep == 13 : exponential dependence (exponential function) in # speciation, linear dependence in extinction - +# . ddep == 14 : exponential dependence (exponential function) in +# speciation, exponential dependence (power function) in extinction +# . ddep == 15 : exponential dependence (power function) in +# speciation, exponential dependence (exponential function) in extinction # - pars2[3] = cond = conditioning # . cond == 0 : conditioning on stem or crown age # . cond == 1 : conditioning on stem or crown age and non-extinction of the phylogeny diff --git a/R/dd_loglik_M.R b/R/dd_loglik_M.R index d76847a..11699c4 100644 --- a/R/dd_loglik_M.R +++ b/R/dd_loglik_M.R @@ -89,6 +89,18 @@ lambdamu = function(n,pars,ddep) # linear DD on extinction lavec = pmax(0, la * ((alpha * (la - mu) + mu) / la) ^ (n / K)) muvec = mu + alpha * (la - mu) * n / K + } else if (ddep == 14) { + # exponential DD on speciation (exponential function) + # exponential DD on extinction (power function) + y = log(1 + alpha * (la - mu) / mu) / log(K) + lavec = pmax(0, la * ((alpha * (la - mu) + mu) / la) ^ (n / K)) + muvec = mu * n ^ y + } else if (ddep == 15) { + # exponential DD on speciation (power function) + # exponential DD on extinction (exponential function) + y = -log(la / (alpha * (la - mu) + mu)) / log(K) + lavec = pmax(0, la * n ^ y) + muvec = mu * (1 + alpha * (la - mu) / mu) ^ (n / K) } return(list(lavec,muvec)) } diff --git a/R/dd_loglik_rhs.R b/R/dd_loglik_rhs.R index e192a96..cc74637 100644 --- a/R/dd_loglik_rhs.R +++ b/R/dd_loglik_rhs.R @@ -75,6 +75,14 @@ dd_loglik_rhs_precomp = function(pars,x) } else if (ddep == 13) { lavec = pmax(0, la * ((alpha * (la - mu) + mu) / la) ^ (nn / K)) muvec = mu + alpha * (la - mu) / K * nn + } else if (ddep == 14) { + y = log(1 + alpha * (la - mu) / mu) / log(K) + lavec = pmax(0, la * ((alpha * (la - mu) + mu) / la) ^ (nn / K)) + muvec = mu * nn ^ y + } else if (ddep == 15) { + y = -log(la / (alpha * (la - mu) + mu)) / log(K) + lavec = pmax(0, la * nn ^ y) + muvec = mu * (1 + alpha * (la - mu) / mu) ^ (nn / K) } return(c(lavec, muvec, nn)) } diff --git a/R/dd_sim.R b/R/dd_sim.R index fb34ff6..d56e562 100644 --- a/R/dd_sim.R +++ b/R/dd_sim.R @@ -67,6 +67,14 @@ dd_lamuN = function(ddmodel,pars,N) { } else if (ddmodel == 13) { laN = max(0, la * ((alpha * (la - mu) + mu) / la) ^ (N / K)) muN = mu + alpha * (la - mu) / K * N + } else if (ddmodel == 14) { + y = log(1 + alpha * (la - mu) / mu) / log(K) + laN = max(0, la * ((alpha * (la - mu) + mu) / la) ^ (N / K)) + muN = mu * N ^ y + } else if (ddmodel == 15) { + y = -log(la / (alpha * (la - mu) + mu)) / log(K) + laN = max(0, la * N ^ y) + muN = mu * (1 + alpha * (la - mu) / mu) ^ (N / K) } return(c(laN,muN)) } diff --git a/man/dd_ML.Rd b/man/dd_ML.Rd index 0e5ff39..33edda7 100644 --- a/man/dd_ML.Rd +++ b/man/dd_ML.Rd @@ -91,7 +91,11 @@ dependence (exponential function) in extinction\cr \code{ddmodel == 12} : exponential dependence (exponential function) in speciation and extinction\cr \code{ddmodel == 13} : exponential dependence (exponential function) in -speciation, linear dependence in extinction \cr} +speciation, linear dependence in extinction \cr +\code{ddmodel == 14} : exponential dependence (exponential function) in +speciation, exponential dependence (power function) in extinction \cr +\code{ddmodel == 15} : exponential dependence (power function) in +speciation, exponential dependence (exponential function) in extinction \cr} \item{missnumspec}{The number of species that are in the clade but missing in the phylogeny} From 42d4d36ea7433dad6fd70789eef7528a28cda1c5 Mon Sep 17 00:00:00 2001 From: Theo Pannetier Date: Wed, 30 Jun 2021 10:13:26 +0200 Subject: [PATCH 26/49] update DD model tests --- tests/testthat/test_ddmodels.R | 48 ++++++++++++++++++---------------- 1 file changed, 25 insertions(+), 23 deletions(-) diff --git a/tests/testthat/test_ddmodels.R b/tests/testthat/test_ddmodels.R index 9509b5c..ae340a9 100644 --- a/tests/testthat/test_ddmodels.R +++ b/tests/testthat/test_ddmodels.R @@ -17,10 +17,10 @@ exptd_rates_set1 <- list( #"mu_cst" = function(N) 0.2, # not with alpha != 0 "lambda_lin" = function(N) pmax(0.8 - 0.0225 * N, 0), "mu_lin" = function(N) 0.2 + 0.0075 * N, - "lambda_exp" = function(N) pmax(0.8 * N ^ (-log(0.8 / 0.35) / log(20)), 0), - "mu_exp" = function(N) 0.2 * N ^ (log(1.75) / log(20)), - "lambda_exp_alt" = function(N) pmax(0.8 * (7 / 16) ^ (N / 20), 0), - 'mu_exp_alt' = function(N) 0.2 * (7 / 4) ^ (N / 20) + "lambda_pow" = function(N) pmax(0.8 * N ^ (-log(0.8 / 0.35) / log(20)), 0), + "mu_pow" = function(N) 0.2 * N ^ (log(1.75) / log(20)), + "lambda_exp" = function(N) pmax(0.8 * (7 / 16) ^ (N / 20), 0), + 'mu_exp' = function(N) 0.2 * (7 / 4) ^ (N / 20) ) # Case 2.: r = 0 (alpha = 0) @@ -35,10 +35,10 @@ exptd_rates_set2 <- list( #"mu_cst" = function(N) 0.2, # not with alpha != 0 "lambda_lin" = function(N) pmax(0.8 - 0.03 * N, 0), "mu_lin" = function(N) rep(0.2, length(N)), - "lambda_exp" = function(N) pmax(0.8 * N ^ (-log(4) / log(20)), 0), - "mu_exp" = function(N) rep(0.2, length(N)), - "lambda_exp_alt" = function(N) pmax(0.8 * (1/4) ^ (N / 20), 0), - 'mu_exp_alt' = function(N) rep(0.2, length(N)) + "lambda_pow" = function(N) pmax(0.8 * N ^ (-log(4) / log(20)), 0), + "mu_pow" = function(N) rep(0.2, length(N)), + "lambda_exp" = function(N) pmax(0.8 * (1 / 4) ^ (N / 20), 0), + 'mu_exp' = function(N) rep(0.2, length(N)) ) # Case 3.: r = Inf (alpha = 1) pars_set3 <- c( @@ -52,10 +52,10 @@ exptd_rates_set3 <- list( #"mu_cst" = function(N) 0.2, # not with alpha != 0 "lambda_lin" = function(N) rep(0.8, length(N)), "mu_lin" = function(N) 0.2 + 0.03 * N, - "lambda_exp" = function(N) rep(0.8, length(N)), - "mu_exp" = function(N) 0.2 * N ^ (log(4) / log(20)), - "lambda_exp_alt" = function(N) rep(0.8, length(N)), - 'mu_exp_alt' = function(N) 0.2 * 4 ^ (N / 20) + "lambda_pow" = function(N) rep(0.8, length(N)), + "mu_pow" = function(N) 0.2 * N ^ (log(4) / log(20)), + "lambda_exp" = function(N) rep(0.8, length(N)), + 'mu_exp' = function(N) 0.2 * 4 ^ (N / 20) ) # Declare test functions @@ -65,14 +65,16 @@ match_exptd_rates <- function(ddmodel, exptd_rates_set, n_seq) { rates_ls <- switch( as.character(ddmodel), "5" = list("la_N" = exptd_rates_set$lambda_lin(n_seq), "mu_N" = exptd_rates_set$mu_lin(n_seq)), - "6" = list("la_N" = exptd_rates_set$lambda_lin(n_seq), "mu_N" = exptd_rates_set$mu_exp(n_seq)), - "7" = list("la_N" = exptd_rates_set$lambda_exp(n_seq), "mu_N" = exptd_rates_set$mu_exp(n_seq)), - "8" = list("la_N" = exptd_rates_set$lambda_exp(n_seq), "mu_N" = exptd_rates_set$mu_lin(n_seq)), - #"9" = list("la_N" = exptd_rates_set$lambda_exp_alt(n_seq), "mu_N" = exptd_rates_set$mu_cst(n_seq)), - #"10" = list("la_N" = exptd_rates_set$lambda_cst(n_seq), "mu_N" = exptd_rates_set$mu_exp_alt(n_seq)), - "11" = list("la_N" = exptd_rates_set$lambda_lin(n_seq), "mu_N" = exptd_rates_set$mu_exp_alt(n_seq)), - "12" = list("la_N" = exptd_rates_set$lambda_exp_alt(n_seq), "mu_N" = exptd_rates_set$mu_exp_alt(n_seq)), - "13" = list("la_N" = exptd_rates_set$lambda_exp_alt(n_seq), "mu_N" = exptd_rates_set$mu_lin(n_seq)), + "6" = list("la_N" = exptd_rates_set$lambda_lin(n_seq), "mu_N" = exptd_rates_set$mu_pow(n_seq)), + "7" = list("la_N" = exptd_rates_set$lambda_pow(n_seq), "mu_N" = exptd_rates_set$mu_pow(n_seq)), + "8" = list("la_N" = exptd_rates_set$lambda_pow(n_seq), "mu_N" = exptd_rates_set$mu_lin(n_seq)), + #"9" = list("la_N" = exptd_rates_set$lambda_exp(n_seq), "mu_N" = exptd_rates_set$mu_cst(n_seq)), + #"10" = list("la_N" = exptd_rates_set$lambda_cst(n_seq), "mu_N" = exptd_rates_set$mu_exp(n_seq)), + "11" = list("la_N" = exptd_rates_set$lambda_lin(n_seq), "mu_N" = exptd_rates_set$mu_exp(n_seq)), + "12" = list("la_N" = exptd_rates_set$lambda_exp(n_seq), "mu_N" = exptd_rates_set$mu_exp(n_seq)), + "13" = list("la_N" = exptd_rates_set$lambda_exp(n_seq), "mu_N" = exptd_rates_set$mu_lin(n_seq)), + "14" = list("la_N" = exptd_rates_set$lambda_exp(n_seq), "mu_N" = exptd_rates_set$mu_pow(n_seq)), + "15" = list("la_N" = exptd_rates_set$lambda_pow(n_seq), "mu_N" = exptd_rates_set$mu_exp(n_seq)) ) return(rates_ls) } @@ -142,7 +144,7 @@ test_dd_lamuN <- function(ddmodel, pars_set, exptd_rates_set) { } test_that("set1", { - ddmodels <- c(5:8, 11:13) + ddmodels <- c(5:8, 11:15) purrr::walk( ddmodels, test_dd_loglik_rhs_precomp, @@ -164,7 +166,7 @@ test_that("set1", { }) test_that("set2", { - ddmodels <- c(5:8, 11:13) + ddmodels <- c(5:8, 11:15) purrr::walk( ddmodels, test_dd_loglik_rhs_precomp, @@ -186,7 +188,7 @@ test_that("set2", { }) test_that("set3", { - ddmodels <- c(5:8, 11:13) + ddmodels <- c(5:8, 11:15) purrr::walk( ddmodels, test_dd_loglik_rhs_precomp, From d2c7a50e423fc131c6171a35ce6dc48f1b01eb8f Mon Sep 17 00:00:00 2001 From: Theo Pannetier Date: Wed, 30 Jun 2021 10:38:26 +0200 Subject: [PATCH 27/49] update both_rates_vary to include new DD models --- R/dd_utils.R | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/R/dd_utils.R b/R/dd_utils.R index 8791210..f857a92 100644 --- a/R/dd_utils.R +++ b/R/dd_utils.R @@ -5,7 +5,6 @@ #' #' Converting a set of branching times to a phylogeny #' -#' #' @param times Set of branching times #' @param root When root is FALSE, the largest branching time will be assumed to be #' the crown age. When root is TRUE, it will be the stem age. @@ -893,7 +892,7 @@ rng_respecting_sample <- function(x, size, replace, prob) { #' @author Theo Pannetier #' @export both_rates_vary <- function(ddmodel) { - return(ddmodel %in% c(5:8, 11:13)) + return(ddmodel %in% c(5:8, 11:15)) } #' Get carrying capacity from other parameters of the model From 4d4791f28ad72831205ad1e0c8223ea3854b3778 Mon Sep 17 00:00:00 2001 From: Theo Pannetier Date: Wed, 30 Jun 2021 15:42:10 +0200 Subject: [PATCH 28/49] fix variable name --- R/dd_ML.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/dd_ML.R b/R/dd_ML.R index 8d7e5e8..c1234ac 100644 --- a/R/dd_ML.R +++ b/R/dd_ML.R @@ -180,7 +180,7 @@ dd_ML = function( } if (ddmodel > 5) { - if (method == "analytical" || cond == 3) { + if (methode == "analytical" || cond == 3) { stop("Sorry, ddmodel options > 5 have not been developed for method = \"analytical\" or cond = 3.") } } From 2c398b4b388167cb05d4e56c63187ce268008d3f Mon Sep 17 00:00:00 2001 From: Theo Pannetier Date: Fri, 10 Sep 2021 11:47:00 +0200 Subject: [PATCH 29/49] fix doc --- man/dd_MS_ML.Rd | 2 +- man/dd_loglik.Rd | 10 +--------- 2 files changed, 2 insertions(+), 10 deletions(-) diff --git a/man/dd_MS_ML.Rd b/man/dd_MS_ML.Rd index 97e95c0..8bbe676 100644 --- a/man/dd_MS_ML.Rd +++ b/man/dd_MS_ML.Rd @@ -26,7 +26,7 @@ dd_MS_ML( changeloglikifnoconv = FALSE, optimmethod = "subplex", num_cycles = 1, - methode = "ode45", + methode = "odeint::runge_kutta_cash_karp54", correction = FALSE, verbose = FALSE ) diff --git a/man/dd_loglik.Rd b/man/dd_loglik.Rd index 280245f..5b8e5a8 100644 --- a/man/dd_loglik.Rd +++ b/man/dd_loglik.Rd @@ -4,15 +4,7 @@ \alias{dd_loglik} \title{Loglikelihood for diversity-dependent diversification models} \usage{ -dd_loglik( - pars1, - pars2, - brts, - missnumspec = 0, - methode = "analytical", - rhs_func_name = ifelse(pars2[3] == 3, "dd_loglik_bw_rhs_FORTRAN", - "dd_loglik_rhs_FORTRAN") -) +dd_loglik(pars1, pars2, brts, missnumspec = 0, methode = "analytical") } \arguments{ \item{pars1}{Vector of parameters: From 591a6b3ba1431d182510794d114df2713684c040 Mon Sep 17 00:00:00 2001 From: Theo Pannetier Date: Fri, 10 Sep 2021 12:33:35 +0200 Subject: [PATCH 30/49] fix unmatched args in tests and missing methode in dd_loglik2 --- R/dd_loglik.R | 12 ++--- tests/testthat/{test_z_DDD.R => test_DDD.R} | 50 ++++++++++----------- tests/testthat/test_pars_dd_loglik.R | 2 +- 3 files changed, 32 insertions(+), 32 deletions(-) rename tests/testthat/{test_z_DDD.R => test_DDD.R} (95%) diff --git a/R/dd_loglik.R b/R/dd_loglik.R index 9cb4078..71eed71 100644 --- a/R/dd_loglik.R +++ b/R/dd_loglik.R @@ -456,7 +456,7 @@ dd_loglik2 = function(pars1,pars2,brts,missnumspec) for(k in 2:(S + 2 - soc)) { k1 = k + (soc - 2) - #y = deSolve::ode(probs,brts[(k-1):k],rhs_func,c(pars1,k1,ddep),rtol = reltol,atol = abstol,method = methode) + #y = deSolve::ode(probs,brts[(k-1):k],rhs_func,c(pars1,k1,ddep),rtol = reltol,atol = abstol,method = "analytical") #probs2 = y[2,2:(lx+1)] probs = dd_loglik_M(pars1,lx,k1,ddep,tt = abs(brts[k] - brts[k-1]),probs) if(is.na(sum(probs)) && pars1[2]/pars1[1] < 1E-4 && missnumspec == 0) @@ -478,7 +478,7 @@ dd_loglik2 = function(pars1,pars2,brts,missnumspec) for(k in (S + 2 - soc):2) { k1 = k + (soc - 2) - #y = deSolve::ode(probs,-brts[k:(k-1)],dd_loglik_bw_rhs,c(pars1,k1,ddep),rtol = reltol,atol = abstol,method = methode) + #y = deSolve::ode(probs,-brts[k:(k-1)],dd_loglik_bw_rhs,c(pars1,k1,ddep),rtol = reltol,atol = abstol,method = "analytical") #probs2 = y[2,2:(lx+2)] probs = dd_loglik_M_bw(pars1,lx,k1,ddep,tt = abs(brts[k] - brts[k-1]),probs[1:lx]) probs = c(probs,0) @@ -504,7 +504,7 @@ dd_loglik2 = function(pars1,pars2,brts,missnumspec) k = soc t1 = brts[1] t2 = brts[S + 2 - soc] - #y = deSolve::ode(probsn,c(t1,t2),rhs_func,c(pars1,k,ddep),rtol = reltol,atol = abstol,method = methode); + #y = deSolve::ode(probsn,c(t1,t2),rhs_func,c(pars1,k,ddep),rtol = reltol,atol = abstol,method = "analytical"); #probsn = y[2,2:(lx+1)] probsn = dd_loglik_M(pars1,lx,k,ddep,tt = abs(t2 - t1),probsn) if(soc == 1) { aux = 1:lx } @@ -518,13 +518,13 @@ dd_loglik2 = function(pars1,pars2,brts,missnumspec) #probsn = rep(0,lx + 1) #probsn[S + missnumspec + 1] = 1 #/ (S + missnumspec) #TT = max(1,1/abs(la - mu)) * 100000000 * max(abs(brts)) # make this more efficient later - #y = deSolve::ode(probsn,c(0,TT),dd_loglik_bw_rhs,c(pars1,0,ddep),rtol = reltol,atol = abstol,method = methode) + #y = deSolve::ode(probsn,c(0,TT),dd_loglik_bw_rhs,c(pars1,0,ddep),rtol = reltol,atol = abstol,method = "analytical") #logliknorm = log(y[2,lx + 2]) probsn = rep(0,lx + 1) probsn[S + missnumspec + 1] = 1 TT = 1e14 # max(1,1/abs(la - mu)) * 1E+10 * max(abs(brts)) # make this more efficient later - y = dd_integrate(probsn,c(0,TT),rhs_func_name,c(pars1,0,ddep),rtol = reltol,atol = abstol,method = methode) + y = dd_integrate(probsn,c(0,TT),rhs_func_name,c(pars1,0,ddep),rtol = reltol,atol = abstol,method = "analytical") logliknorm = log(y[2,lx + 2]) if(soc == 2) { @@ -532,7 +532,7 @@ dd_loglik2 = function(pars1,pars2,brts,missnumspec) #probsn[1:lx] = probs[1:lx] #probsn = c(flavec(ddep,la,mu,K,r,lx,1),1) * probsn # speciation event #probsn = c(lambdamu(0:(lx - 1) + 1,pars1,ddep)[[1]],1) * probsn # speciation event - #y = deSolve::ode(probsn,c(max(abs(brts)),TT),dd_loglik_bw_rhs,c(pars1,1,ddep),rtol = reltol,atol = abstol,method = methode) + #y = deSolve::ode(probsn,c(max(abs(brts)),TT),dd_loglik_bw_rhs,c(pars1,1,ddep),rtol = reltol,atol = abstol,method = "analytical") #logliknorm = logliknorm - log(y[2,lx + 2]) probsn2 = rep(0,lx) probsn2 = lambdamu(0:(lx - 1) + 1,pars1,ddep)[[1]] * probs[1:lx] diff --git a/tests/testthat/test_z_DDD.R b/tests/testthat/test_DDD.R similarity index 95% rename from tests/testthat/test_z_DDD.R rename to tests/testthat/test_DDD.R index a90851b..60fc9a4 100644 --- a/tests/testthat/test_z_DDD.R +++ b/tests/testthat/test_DDD.R @@ -21,8 +21,8 @@ test_that("DDD works", { methode = 'analytical' r0 <- dd_loglik(pars1 = pars1,pars2 = pars2,brts = brts,missnumspec = missnumspec,methode = methode) - r1 <- dd_loglik(pars1 = pars1,pars2 = pars2,brts = brts,missnumspec = missnumspec,rhs_func_name = 'dd_loglik_rhs', methode = methode) - r2 <- dd_loglik(pars1 = pars1,pars2 = pars2,brts = brts,missnumspec = missnumspec,rhs_func_name = 'dd_loglik_rhs_FORTRAN',methode = methode) + r1 <- dd_loglik(pars1 = pars1,pars2 = pars2,brts = brts,missnumspec = missnumspec,methode = methode) + r2 <- dd_loglik(pars1 = pars1,pars2 = pars2,brts = brts,missnumspec = missnumspec,methode = methode) r3 <- dd_loglik(pars1 = pars1,pars2 = pars2,brts = brts,missnumspec = missnumspec,methode = 'analytical') testthat::expect_equal(r0,r2,tolerance = .00001) @@ -35,8 +35,8 @@ test_that("DDD works", { brts = 1:5 pars2 = c(100,1,3,0,0,2) - r5 <- dd_loglik(pars1 = pars1,pars2 = pars2,brts = brts,missnumspec = missnumspec,rhs_func_name = 'dd_loglik_bw_rhs',methode = methode) - r6 <- dd_loglik(pars1 = pars1,pars2 = pars2,brts = brts,missnumspec = missnumspec,rhs_func_name = 'dd_loglik_bw_rhs_FORTRAN',methode = methode) + r5 <- dd_loglik(pars1 = pars1,pars2 = pars2,brts = brts,missnumspec = missnumspec,methode = methode) + r6 <- dd_loglik(pars1 = pars1,pars2 = pars2,brts = brts,missnumspec = missnumspec,methode = methode) r7 <- dd_loglik(pars1 = pars1,pars2 = pars2,brts = brts,missnumspec = missnumspec,methode = 'analytical') testthat::expect_equal(r5,r6,tolerance = .00001) @@ -46,8 +46,8 @@ test_that("DDD works", { pars1 = c(0.2,0.05,1000000) pars2 = c(1000,1,1,0,0,2) brts = 1:10 - r8 <- dd_loglik(pars1 = pars1,pars2 = pars2,brts = brts,missnumspec = missnumspec,rhs_func_name = 'dd_loglik_rhs_FORTRAN',methode = methode) - r9 <- dd_loglik(pars1 = c(pars1[1:2],Inf),pars2 = pars2,brts = brts,missnumspec = missnumspec,rhs_func_name = 'dd_loglik_rhs_FORTRAN',methode = methode) + r8 <- dd_loglik(pars1 = pars1,pars2 = pars2,brts = brts,missnumspec = missnumspec,methode = methode) + r9 <- dd_loglik(pars1 = c(pars1[1:2],Inf),pars2 = pars2,brts = brts,missnumspec = missnumspec,methode = methode) expect_equal_x64(r8,r9,tolerance = .00001) pars1 <- c(0.2,0.05,15) @@ -71,7 +71,7 @@ test_that("DDD_KI works", # brts = brts, # cond = 0, # n_max = 1e3 - #); + #) high_k <- 1e7 pars1 <- c(pars[1], pars[2], high_k, pars[3], pars[4], high_k, brts[[2]][1]) pars2 <- c(500,1,0,brts[[2]][1],0,2,1.5) @@ -84,7 +84,7 @@ test_that("DDD_KI works", brtsS = brtsS, missnumspec = 0, methode = 'odeint::runge_kutta_cash_karp54' - ); + ) testthat::expect_equal(ddd_test,-24.4171970357049624,tolerance = .000001) ddd_test2 <- DDD::dd_KI_loglik( pars1 = pars1, @@ -93,7 +93,7 @@ test_that("DDD_KI works", brtsS = brtsS, missnumspec = 0, methode = 'analytical' - ); + ) testthat::expect_equal(ddd_test,ddd_test2,tolerance = .000001) low_k <- 20 @@ -105,7 +105,7 @@ test_that("DDD_KI works", brtsS = brtsS, missnumspec = 0, methode = 'odeint::runge_kutta_cash_karp54' - ); + ) testthat::expect_equal(ddd_test,-21.1781625797899231,tolerance = .000001) ddd_test2 <- DDD::dd_KI_loglik( pars1 = pars1, @@ -114,7 +114,7 @@ test_that("DDD_KI works", brtsS = brtsS, missnumspec = 0, methode = 'analytical' - ); + ) testthat::expect_equal(ddd_test,ddd_test2,tolerance = .000001) ddd_test3 <- DDD::dd_KI_loglik( @@ -124,7 +124,7 @@ test_that("DDD_KI works", brtsS = brtsS, missnumspec = 3, methode = 'odeint::runge_kutta_cash_karp54' - ); + ) testthat::expect_equal(ddd_test3,-19.6273910107265408,tolerance = .000001) ddd_test03 <- DDD::dd_KI_loglik( @@ -134,7 +134,7 @@ test_that("DDD_KI works", brtsS = brtsS, missnumspec = c(0,3), methode = 'odeint::runge_kutta_cash_karp54' - ); + ) testthat::expect_equal(ddd_test03,-21.4981352311200595,tolerance = .000001) ddd_test12 <- DDD::dd_KI_loglik( @@ -144,7 +144,7 @@ test_that("DDD_KI works", brtsS = brtsS, missnumspec = c(1,2), methode = 'odeint::runge_kutta_cash_karp54' - ); + ) testthat::expect_equal(ddd_test12,-20.7167138427128776,tolerance = .000001) ddd_test21 <- DDD::dd_KI_loglik( @@ -154,7 +154,7 @@ test_that("DDD_KI works", brtsS = brtsS, missnumspec = c(2,1), methode = 'odeint::runge_kutta_cash_karp54' - ); + ) testthat::expect_equal(ddd_test21,-20.0405933298708874,tolerance = .000001) ddd_test30 <- DDD::dd_KI_loglik( @@ -164,7 +164,7 @@ test_that("DDD_KI works", brtsS = brtsS, missnumspec = c(3,0), methode = 'odeint::runge_kutta_cash_karp54' - ); + ) testthat::expect_equal(ddd_test30,-19.4834201422017124,tolerance = .000001) #testthat::expect_equal(ddd_test3,log(exp(ddd_test03) + exp(ddd_test12) + exp(ddd_test21) + exp(ddd_test30)),tolerance = .000001) @@ -178,7 +178,7 @@ test_that("DDD_KI works", brtsS = brtsS, missnumspec = 0, methode = 'odeint::runge_kutta_cash_karp54' - ); + ) testthat::expect_equal(ddd_test,-20.5299241171281643,tolerance = .000001) ddd_test2 <- DDD::dd_KI_loglik( pars1 = pars1, @@ -187,7 +187,7 @@ test_that("DDD_KI works", brtsS = brtsS, missnumspec = 0, methode = 'analytical' - ); + ) testthat::expect_equal(ddd_test,ddd_test2,tolerance = .000001) pars2[3] <- 4 @@ -198,7 +198,7 @@ test_that("DDD_KI works", brtsS = brtsS, missnumspec = 0, methode = 'odeint::runge_kutta_cash_karp54' - ); + ) testthat::expect_equal(ddd_test,-20.2509115267895616,tolerance = .000001) pars2[3] <- 5 @@ -209,7 +209,7 @@ test_that("DDD_KI works", brtsS = brtsS, missnumspec = 0, methode = 'odeint::runge_kutta_cash_karp54' - ); + ) testthat::expect_equal(ddd_test,-20.1686905596579997,tolerance = .000001) cond <- 1 @@ -220,7 +220,7 @@ test_that("DDD_KI works", # brts = brts, # cond = cond, # n_max = 1e3 - # ); + # ) t_d <- brts[[2]][1] tsplit <- min(abs(brts[[1]][abs(brts[[1]]) > t_d])) high_k <- 1e7 @@ -235,7 +235,7 @@ test_that("DDD_KI works", brtsS = brtsS, missnumspec = 0, methode = 'analytical' - ); + ) testthat::expect_equal(ddd_test1,-28.5415506633517460,tolerance = .000001) cond <- 0 pars2 <- c(200,1,cond,brts[[2]][1],0,2,1.5) @@ -272,9 +272,9 @@ context("test_DDD_KI_conditioning") test_that("conditioning_DDD_KI works", { skip_if(Sys.getenv("CI") == "", message = "Run only on CI") - ts <- seq(-9,-1,2); - p1 <- rep(0,5); - p2 <- rep(0,5); + ts <- seq(-9,-1,2) + p1 <- rep(0,5) + p2 <- rep(0,5) pars1_list <- list(c(0.5,0.4,Inf),c(0,0,Inf)) reltol <- 1e-8 abstol <- 1e-8 diff --git a/tests/testthat/test_pars_dd_loglik.R b/tests/testthat/test_pars_dd_loglik.R index 3fe8c5f..7556906 100644 --- a/tests/testthat/test_pars_dd_loglik.R +++ b/tests/testthat/test_pars_dd_loglik.R @@ -20,7 +20,7 @@ run_dd_loglik <- function(ddmodel, lambda_0 = 0.8, mu_0 = 0.1, K = 20, r = 1, ve pars2 = pars2, brts = brts, # defined above missnumspec = 0, - methode = "'odeint::runge_kutta_cash_karp54'" + methode = "odeint::runge_kutta_cash_karp54" ) } From 51cc0f5463a213aa233a807a0ad791875b8e3cb2 Mon Sep 17 00:00:00 2001 From: Theo Pannetier Date: Fri, 10 Sep 2021 13:28:51 +0200 Subject: [PATCH 31/49] rm purrr dependency --- tests/testthat/test_ddmodels.R | 45 +++++++++++++++++----------------- 1 file changed, 23 insertions(+), 22 deletions(-) diff --git a/tests/testthat/test_ddmodels.R b/tests/testthat/test_ddmodels.R index ae340a9..7c401ae 100644 --- a/tests/testthat/test_ddmodels.R +++ b/tests/testthat/test_ddmodels.R @@ -131,12 +131,12 @@ test_dd_lamuN <- function(ddmodel, pars_set, exptd_rates_set) { n_seq = n_seq ) ddd_rates <- list( - "la_N" = purrr::map_dbl(n_seq, function(n) { + "la_N" = unlist(lapply(n_seq, function(n) { dd_lamuN(ddmodel = ddmodel, pars = pars_set, N = n)[1] - }), - "mu_N" = purrr::map_dbl(n_seq, function(n) { + }), use.names = FALSE), + "mu_N" = unlist(lapply(n_seq, function(n) { dd_lamuN(ddmodel = ddmodel, pars = pars_set, N = n)[2] - }) + }), use.names = FALSE) ) # Test cat(paste("Testing ddmodel =", ddmodel, "\n")) @@ -145,67 +145,68 @@ test_dd_lamuN <- function(ddmodel, pars_set, exptd_rates_set) { test_that("set1", { ddmodels <- c(5:8, 11:15) - purrr::walk( + + invisible(lapply( ddmodels, test_dd_loglik_rhs_precomp, pars_set = pars_set1, exptd_rates_set = exptd_rates_set1 - ) - purrr::walk( + )) + invisible(lapply( ddmodels, test_lambdamu, pars_set = pars_set1, exptd_rates_set = exptd_rates_set1 - ) - purrr::walk( + )) + invisible(lapply( ddmodels, test_dd_lamuN, pars_set = pars_set1, exptd_rates_set = exptd_rates_set1 - ) + )) }) test_that("set2", { ddmodels <- c(5:8, 11:15) - purrr::walk( + invisible(lapply( ddmodels, test_dd_loglik_rhs_precomp, pars_set = pars_set2, exptd_rates_set = exptd_rates_set2 - ) - purrr::walk( + )) + invisible(lapply( ddmodels, test_lambdamu, pars_set = pars_set2, exptd_rates_set = exptd_rates_set2 - ) - purrr::walk( + )) + invisible(lapply( ddmodels, test_dd_lamuN, pars_set = pars_set2, exptd_rates_set = exptd_rates_set2 - ) + )) }) test_that("set3", { ddmodels <- c(5:8, 11:15) - purrr::walk( + invisible(lapply( ddmodels, test_dd_loglik_rhs_precomp, pars_set = pars_set3, exptd_rates_set = exptd_rates_set3 - ) - purrr::walk( + )) + invisible(lapply( ddmodels, test_lambdamu, pars_set = pars_set3, exptd_rates_set = exptd_rates_set3 - ) - purrr::walk( + )) + invisible(lapply( ddmodels, test_dd_lamuN, pars_set = pars_set3, exptd_rates_set = exptd_rates_set3 - ) + )) }) From 1b738d3a06ac917bd97c2219baa3458ffab4a2c2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Pannetier?= Date: Fri, 10 Sep 2021 14:43:41 +0200 Subject: [PATCH 32/49] check new-ddmodels branch on GHA --- .github/workflows/R-CMD-check.yaml | 2 ++ 1 file changed, 2 insertions(+) diff --git a/.github/workflows/R-CMD-check.yaml b/.github/workflows/R-CMD-check.yaml index e42de16..a72b411 100644 --- a/.github/workflows/R-CMD-check.yaml +++ b/.github/workflows/R-CMD-check.yaml @@ -7,6 +7,7 @@ on: - master - develop - richel + - new-ddmodels pull_request: branches: @@ -14,6 +15,7 @@ on: - master - develop - richel + - new-ddmodels name: R-CMD-check From 125c92273c617078731c57a50030373eb235109f Mon Sep 17 00:00:00 2001 From: Theo Pannetier Date: Fri, 10 Sep 2021 23:25:23 +0200 Subject: [PATCH 33/49] fix some bits I missed in the last merge --- DESCRIPTION | 2 +- R/dd_loglik.R | 14 ++++++++------ 2 files changed, 9 insertions(+), 7 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index ccd2419..572523f 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -2,7 +2,7 @@ Package: DDD Type: Package Title: Diversity-Dependent Diversification Version: 5.0 -Date: 2021-07-16 +Date: 2021-09-10 Depends: R (>= 3.5.0) Imports: deSolve, ape, phytools, subplex, Matrix, expm, SparseM, Rcpp (>= 1.0.5) LinkingTo: Rcpp, BH diff --git a/R/dd_loglik.R b/R/dd_loglik.R index 71eed71..25f66fe 100644 --- a/R/dd_loglik.R +++ b/R/dd_loglik.R @@ -504,7 +504,7 @@ dd_loglik2 = function(pars1,pars2,brts,missnumspec) k = soc t1 = brts[1] t2 = brts[S + 2 - soc] - #y = deSolve::ode(probsn,c(t1,t2),rhs_func,c(pars1,k,ddep),rtol = reltol,atol = abstol,method = "analytical"); + #y = deSolve::ode(probsn,c(t1,t2),rhs_func,c(pars1,k,ddep),rtol = reltol,atol = abstol,method = "analytical") #probsn = y[2,2:(lx+1)] probsn = dd_loglik_M(pars1,lx,k,ddep,tt = abs(t2 - t1),probsn) if(soc == 1) { aux = 1:lx } @@ -521,11 +521,13 @@ dd_loglik2 = function(pars1,pars2,brts,missnumspec) #y = deSolve::ode(probsn,c(0,TT),dd_loglik_bw_rhs,c(pars1,0,ddep),rtol = reltol,atol = abstol,method = "analytical") #logliknorm = log(y[2,lx + 2]) probsn = rep(0,lx + 1) - probsn[S + missnumspec + 1] = 1 - - TT = 1e14 # max(1,1/abs(la - mu)) * 1E+10 * max(abs(brts)) # make this more efficient later - y = dd_integrate(probsn,c(0,TT),rhs_func_name,c(pars1,0,ddep),rtol = reltol,atol = abstol,method = "analytical") - logliknorm = log(y[2,lx + 2]) + probsn[2] = 1 + MM = dd_loglik_M_aux(pars1,lx + 1,k = 0,ddep) + MM = MM[-1,-1] + #probsn = SparseM::solve(-MM,probsn[2:(lx + 1)]) + MMinv = SparseM::solve(MM) + probsn = -MMinv %*% probsn[2:(lx + 1)] + logliknorm = log(probsn[S + missnumspec]) if(soc == 2) { #probsn = rep(0,lx + 1) From 36883a28c71795ecc3e2eebe2c2d0d5a31a1725e Mon Sep 17 00:00:00 2001 From: Theo Pannetier Date: Thu, 23 Sep 2021 12:38:48 +0200 Subject: [PATCH 34/49] changed name of parameter alpha to phi --- R/dd_loglik_M.R | 38 +++++++++++++++++----------------- R/dd_sim.R | 38 +++++++++++++++++----------------- tests/testthat/test_ddmodels.R | 22 ++++++++++---------- 3 files changed, 49 insertions(+), 49 deletions(-) diff --git a/R/dd_loglik_M.R b/R/dd_loglik_M.R index 11699c4..2cfc7a8 100644 --- a/R/dd_loglik_M.R +++ b/R/dd_loglik_M.R @@ -5,7 +5,7 @@ lambdamu = function(n,pars,ddep) mu = pars[2] K = pars[3] r = pars[4] - alpha <- ifelse(r == Inf, 1, r / (1 + r)) # else r/(1+r) is NaN + phi <- ifelse(r == Inf, 1, r / (1 + r)) # else r/(1+r) is NaN n0 = (ddep == 2 | ddep == 4) if(ddep == 1) { # linear DD on speciation (K = equilibrium diversity) @@ -43,27 +43,27 @@ lambdamu = function(n,pars,ddep) } else if (ddep == 5) { # linear DD on speciation # linear DD on extinction - lavec = pmax(0, la - (1 - alpha) * (la - mu) * n / K) - muvec = mu + alpha * (la - mu) * n / K + lavec = pmax(0, la - (1 - phi) * (la - mu) * n / K) + muvec = mu + phi * (la - mu) * n / K } else if (ddep == 6) { # linear DD on speciation # "exponential" DD on extinction (power function) - y = log(1 + alpha * (la - mu) / mu) / log(K) - lavec = pmax(0, la - (1 - alpha) * (la - mu) * n / K) + y = log(1 + phi * (la - mu) / mu) / log(K) + lavec = pmax(0, la - (1 - phi) * (la - mu) * n / K) muvec = mu * n ^ y } else if (ddep == 7) { # "exponential" DD on speciation (power function) # "exponential" DD on extinction (power function) - y1 = -log(la / (alpha * (la - mu) + mu)) / log(K) - y2 = log(1 + alpha * (la - mu) / mu) / log(K) + y1 = -log(la / (phi * (la - mu) + mu)) / log(K) + y2 = log(1 + phi * (la - mu) / mu) / log(K) lavec = pmax(0, la * n ^ y1) muvec = mu * n ^ y2 } else if (ddep == 8) { # "exponential" DD on speciation (power function) # linear DD on extinction - y = -log(la / (alpha * (la - mu) + mu)) / log(K) + y = -log(la / (phi * (la - mu) + mu)) / log(K) lavec = pmax(0, la * n ^ y) - muvec = mu + alpha * (la - mu) / K * n + muvec = mu + phi * (la - mu) / K * n } else if (ddep == 9) { # exponential DD on speciation (exponential function) # constant-rate extinction @@ -77,30 +77,30 @@ lambdamu = function(n,pars,ddep) } else if (ddep == 11) { # linear DD on speciation # exponential DD on extinction (exponential function) - lavec = pmax(0, la - (1 - alpha) * (la - mu) * n / K) - muvec = mu * (1 + alpha * (la - mu) / mu) ^ (n / K) + lavec = pmax(0, la - (1 - phi) * (la - mu) * n / K) + muvec = mu * (1 + phi * (la - mu) / mu) ^ (n / K) } else if (ddep == 12) { # exponential DD on speciation (exponential function) # exponential DD on extinction (exponential function) - lavec = pmax(0, la * ((alpha * (la - mu) + mu) / la) ^ (n / K)) - muvec = mu * (1 + alpha * (la - mu) / mu) ^ (n / K) + lavec = pmax(0, la * ((phi * (la - mu) + mu) / la) ^ (n / K)) + muvec = mu * (1 + phi * (la - mu) / mu) ^ (n / K) } else if (ddep == 13) { # exponential DD on speciation (exponential function) # linear DD on extinction - lavec = pmax(0, la * ((alpha * (la - mu) + mu) / la) ^ (n / K)) - muvec = mu + alpha * (la - mu) * n / K + lavec = pmax(0, la * ((phi * (la - mu) + mu) / la) ^ (n / K)) + muvec = mu + phi * (la - mu) * n / K } else if (ddep == 14) { # exponential DD on speciation (exponential function) # exponential DD on extinction (power function) - y = log(1 + alpha * (la - mu) / mu) / log(K) - lavec = pmax(0, la * ((alpha * (la - mu) + mu) / la) ^ (n / K)) + y = log(1 + phi * (la - mu) / mu) / log(K) + lavec = pmax(0, la * ((phi * (la - mu) + mu) / la) ^ (n / K)) muvec = mu * n ^ y } else if (ddep == 15) { # exponential DD on speciation (power function) # exponential DD on extinction (exponential function) - y = -log(la / (alpha * (la - mu) + mu)) / log(K) + y = -log(la / (phi * (la - mu) + mu)) / log(K) lavec = pmax(0, la * n ^ y) - muvec = mu * (1 + alpha * (la - mu) / mu) ^ (n / K) + muvec = mu * (1 + phi * (la - mu) / mu) ^ (n / K) } return(list(lavec,muvec)) } diff --git a/R/dd_sim.R b/R/dd_sim.R index d56e562..eb594a0 100644 --- a/R/dd_sim.R +++ b/R/dd_sim.R @@ -6,7 +6,7 @@ dd_lamuN = function(ddmodel,pars,N) { n0 = (ddmodel == 2 | ddmodel == 4) if (length(pars) == 4) { r = pars[4] - alpha <- ifelse(r == Inf, 1, r / (1 + r)) + phi <- ifelse(r == Inf, 1, r / (1 + r)) } if (ddmodel == 1) { # linear dependence in speciation rate @@ -37,21 +37,21 @@ dd_lamuN = function(ddmodel,pars,N) { muN = mu * (N + n0)^al } else if (ddmodel == 5) { # linear dependence in speciation rate and extinction rate - laN = max(0, la - (1 - alpha) * (la - mu) * N / K) - muN = mu + alpha * (la - mu) * N / K + laN = max(0, la - (1 - phi) * (la - mu) * N / K) + muN = mu + phi * (la - mu) * N / K } else if (ddmodel == 6) { - y = log(1 + alpha * (la - mu) / mu) / log(K) - laN = max(0, la - (1 - alpha) * (la - mu) * N / K) + y = log(1 + phi * (la - mu) / mu) / log(K) + laN = max(0, la - (1 - phi) * (la - mu) * N / K) muN = mu * N ^ y } else if (ddmodel == 7) { - y1 = -log(la / (alpha * (la - mu) + mu)) / log(K) - y2 = log(1 + alpha * (la - mu) / mu) / log(K) + y1 = -log(la / (phi * (la - mu) + mu)) / log(K) + y2 = log(1 + phi * (la - mu) / mu) / log(K) laN = max(0, la * N ^ y1) muN = mu * N ^ y2 } else if (ddmodel == 8) { - y = -log(la / (alpha * (la - mu) + mu)) / log(K) + y = -log(la / (phi * (la - mu) + mu)) / log(K) laN = max(0, la * N ^ y) - muN = mu + alpha * (la - mu) / K * N + muN = mu + phi * (la - mu) / K * N } else if (ddmodel == 9) { laN = max(0, la * (mu / la) ^ (N / K)) muN = mu @@ -59,22 +59,22 @@ dd_lamuN = function(ddmodel,pars,N) { laN = la muN = mu * (la / mu) ^ (N / K) } else if (ddmodel == 11) { - laN = max(0, la - (1 - alpha) * (la - mu) / K * N) - muN = mu * (1 + alpha * (la - mu) / mu) ^ (N / K) + laN = max(0, la - (1 - phi) * (la - mu) / K * N) + muN = mu * (1 + phi * (la - mu) / mu) ^ (N / K) } else if (ddmodel == 12) { - laN = max(0, la * ((alpha * (la - mu) + mu) / la) ^ (N / K)) - muN = mu * (1 + alpha * (la - mu) / mu) ^ (N / K) + laN = max(0, la * ((phi * (la - mu) + mu) / la) ^ (N / K)) + muN = mu * (1 + phi * (la - mu) / mu) ^ (N / K) } else if (ddmodel == 13) { - laN = max(0, la * ((alpha * (la - mu) + mu) / la) ^ (N / K)) - muN = mu + alpha * (la - mu) / K * N + laN = max(0, la * ((phi * (la - mu) + mu) / la) ^ (N / K)) + muN = mu + phi * (la - mu) / K * N } else if (ddmodel == 14) { - y = log(1 + alpha * (la - mu) / mu) / log(K) - laN = max(0, la * ((alpha * (la - mu) + mu) / la) ^ (N / K)) + y = log(1 + phi * (la - mu) / mu) / log(K) + laN = max(0, la * ((phi * (la - mu) + mu) / la) ^ (N / K)) muN = mu * N ^ y } else if (ddmodel == 15) { - y = -log(la / (alpha * (la - mu) + mu)) / log(K) + y = -log(la / (phi * (la - mu) + mu)) / log(K) laN = max(0, la * N ^ y) - muN = mu * (1 + alpha * (la - mu) / mu) ^ (N / K) + muN = mu * (1 + phi * (la - mu) / mu) ^ (N / K) } return(c(laN,muN)) } diff --git a/tests/testthat/test_ddmodels.R b/tests/testthat/test_ddmodels.R index 7c401ae..df2e2d5 100644 --- a/tests/testthat/test_ddmodels.R +++ b/tests/testthat/test_ddmodels.R @@ -3,18 +3,18 @@ context("test_ddmodels") # I do not test models 1 through 4; these have been implemented for a long time # and I assume they have been thoroughly tested -# Case 1.: 0 < r < Inf (or 0 < alpha < 1) +# Case 1.: 0 < r < Inf (or 0 < phi < 1) pars_set1 <- c( "lambda_0" = 0.8, "mu_0" = 0.2, "K" = 20, - "r" = 1/3 # corresponds to alpha = 1/4 + "r" = 1/3 # corresponds to phi = 1/4 ) -# cat(paste("Testing ddmodels with lambda_0 =", pars_set1[1], "mu_0 =", pars_set1[2], "K =", pars_set1[3],"alpha =", round(pars_set1[4], 3), "\n")) +# cat(paste("Testing ddmodels with lambda_0 =", pars_set1[1], "mu_0 =", pars_set1[2], "K =", pars_set1[3],"phi =", round(pars_set1[4], 3), "\n")) # Rates obtained on paper exptd_rates_set1 <- list( - #"lambda_cst" = function(N) 0.8, # not with alpha != 1 - #"mu_cst" = function(N) 0.2, # not with alpha != 0 + #"lambda_cst" = function(N) 0.8, # not with phi != 1 + #"mu_cst" = function(N) 0.2, # not with phi != 0 "lambda_lin" = function(N) pmax(0.8 - 0.0225 * N, 0), "mu_lin" = function(N) 0.2 + 0.0075 * N, "lambda_pow" = function(N) pmax(0.8 * N ^ (-log(0.8 / 0.35) / log(20)), 0), @@ -23,7 +23,7 @@ exptd_rates_set1 <- list( 'mu_exp' = function(N) 0.2 * (7 / 4) ^ (N / 20) ) -# Case 2.: r = 0 (alpha = 0) +# Case 2.: r = 0 (phi = 0) pars_set2 <- c( "lambda_0" = 0.8, "mu_0" = 0.2, @@ -31,8 +31,8 @@ pars_set2 <- c( "r" = 0 ) exptd_rates_set2 <- list( - #"lambda_cst" = function(N) 0.8, # not with alpha != 1 - #"mu_cst" = function(N) 0.2, # not with alpha != 0 + #"lambda_cst" = function(N) 0.8, # not with phi != 1 + #"mu_cst" = function(N) 0.2, # not with phi != 0 "lambda_lin" = function(N) pmax(0.8 - 0.03 * N, 0), "mu_lin" = function(N) rep(0.2, length(N)), "lambda_pow" = function(N) pmax(0.8 * N ^ (-log(4) / log(20)), 0), @@ -40,7 +40,7 @@ exptd_rates_set2 <- list( "lambda_exp" = function(N) pmax(0.8 * (1 / 4) ^ (N / 20), 0), 'mu_exp' = function(N) rep(0.2, length(N)) ) -# Case 3.: r = Inf (alpha = 1) +# Case 3.: r = Inf (phi = 1) pars_set3 <- c( "lambda_0" = 0.8, "mu_0" = 0.2, @@ -48,8 +48,8 @@ pars_set3 <- c( "r" = Inf ) exptd_rates_set3 <- list( - #"lambda_cst" = function(N) 0.8, # not with alpha != 1 - #"mu_cst" = function(N) 0.2, # not with alpha != 0 + #"lambda_cst" = function(N) 0.8, # not with phi != 1 + #"mu_cst" = function(N) 0.2, # not with phi != 0 "lambda_lin" = function(N) rep(0.8, length(N)), "mu_lin" = function(N) 0.2 + 0.03 * N, "lambda_pow" = function(N) rep(0.8, length(N)), From e2243c30fae4a27528943261268aa88c2d40fe3f Mon Sep 17 00:00:00 2001 From: Theo Pannetier Date: Mon, 27 Sep 2021 12:38:47 +0200 Subject: [PATCH 35/49] rewrote exponential DD models to make the exponential term visible --- R/dd_loglik_M.R | 32 +++++++++++++++++----------- R/dd_loglik_rhs.R | 54 +++++++++++++++++++++++++++-------------------- R/dd_sim.R | 32 +++++++++++++++++----------- 3 files changed, 71 insertions(+), 47 deletions(-) diff --git a/R/dd_loglik_M.R b/R/dd_loglik_M.R index 2cfc7a8..5548219 100644 --- a/R/dd_loglik_M.R +++ b/R/dd_loglik_M.R @@ -67,40 +67,48 @@ lambdamu = function(n,pars,ddep) } else if (ddep == 9) { # exponential DD on speciation (exponential function) # constant-rate extinction - lavec = pmax(0, la * (mu / la) ^ (n / K)) + y = log(la / mu) / K + lavec = pmax(0, la * exp(-n * y)) muvec = rep(mu, lnn) } else if (ddep == 10) { # constant-rate speciation # exponential DD on extinction (exponential function) + y = log(la / mu) / K lavec = rep(la, lnn) - muvec = mu * (la / mu) ^ (n / K) + muvec = mu * exp(n * y) } else if (ddep == 11) { # linear DD on speciation # exponential DD on extinction (exponential function) + y = log((phi * la + (1 - phi) * mu) / mu) / K lavec = pmax(0, la - (1 - phi) * (la - mu) * n / K) - muvec = mu * (1 + phi * (la - mu) / mu) ^ (n / K) + muvec = mu * exp(n * y) } else if (ddep == 12) { # exponential DD on speciation (exponential function) # exponential DD on extinction (exponential function) - lavec = pmax(0, la * ((phi * (la - mu) + mu) / la) ^ (n / K)) - muvec = mu * (1 + phi * (la - mu) / mu) ^ (n / K) + y1 = log(la / (phi * la + (1 - phi) * mu)) / K + y2 = log((phi * la + (1 - phi) * mu) / mu) / K + lavec = pmax(0, la * exp(-n * y1)) + muvec = mu * exp(n * y2) } else if (ddep == 13) { # exponential DD on speciation (exponential function) # linear DD on extinction - lavec = pmax(0, la * ((phi * (la - mu) + mu) / la) ^ (n / K)) + y = log(la / (phi * la + (1 - phi) * mu)) / K + lavec = pmax(0, la * exp(-n * y)) muvec = mu + phi * (la - mu) * n / K } else if (ddep == 14) { # exponential DD on speciation (exponential function) # exponential DD on extinction (power function) - y = log(1 + phi * (la - mu) / mu) / log(K) - lavec = pmax(0, la * ((phi * (la - mu) + mu) / la) ^ (n / K)) - muvec = mu * n ^ y + y1 = log(la / (phi * la + (1 - phi) * mu)) / K + y2 = log(1 + phi * (la - mu) / mu) / log(K) + lavec = pmax(0, la * exp(-n * y1)) + muvec = mu * n ^ y2 } else if (ddep == 15) { # exponential DD on speciation (power function) # exponential DD on extinction (exponential function) - y = -log(la / (phi * (la - mu) + mu)) / log(K) - lavec = pmax(0, la * n ^ y) - muvec = mu * (1 + phi * (la - mu) / mu) ^ (n / K) + y1 = -log(la / (phi * (la - mu) + mu)) / log(K) + y2 = log((phi * la + (1 - phi) * mu) / mu) / K + lavec = pmax(0, la * n ^ y1) + muvec = mu * exp(n * y2) } return(list(lavec,muvec)) } diff --git a/R/dd_loglik_rhs.R b/R/dd_loglik_rhs.R index cc74637..823bae1 100644 --- a/R/dd_loglik_rhs.R +++ b/R/dd_loglik_rhs.R @@ -11,7 +11,7 @@ dd_loglik_rhs_precomp = function(pars,x) r = pars[4] kk = pars[5] ddep = pars[6] - alpha <- ifelse(r == Inf, 1, r / (1 + r)) # else r/(1+r) can be NaN + phi <- ifelse(r == Inf, 1, r / (1 + r)) # else r/(1+r) can be NaN } n0 = (ddep == 2 | ddep == 4) @@ -45,44 +45,52 @@ dd_loglik_rhs_precomp = function(pars,x) y = (log(la / mu) / log(K + n0)) ^ (ddep != 4.2) muvec = mu * (nn + n0) ^ y } else if (ddep == 5) { - lavec = pmax(0, la - (1 - alpha) * (la - mu) * nn / K) - muvec = mu + alpha * (la - mu) / K * nn + lavec = pmax(0, la - (1 - phi) * (la - mu) * nn / K) + muvec = mu + phi * (la - mu) / K * nn } else if (ddep == 6) { - y = log(1 + alpha * (la - mu) / mu) / log(K) - lavec = pmax(0, la - (1 - alpha) * (la - mu) * nn / K) + y = log(1 + phi * (la - mu) / mu) / log(K) + lavec = pmax(0, la - (1 - phi) * (la - mu) * nn / K) muvec = mu * nn ^ y } else if (ddep == 7) { - y1 = -log(la / (alpha * (la - mu) + mu)) / log(K) - y2 = log(1 + alpha * (la - mu) / mu) / log(K) + y1 = -log(la / (phi * (la - mu) + mu)) / log(K) + y2 = log(1 + phi * (la - mu) / mu) / log(K) lavec = pmax(0, la * nn ^ y1) muvec = mu * nn ^ y2 } else if (ddep == 8) { - y = -log(la / (alpha * (la - mu) + mu)) / log(K) + y = -log(la / (phi * (la - mu) + mu)) / log(K) lavec = pmax(0, la * nn ^ y) - muvec = mu + alpha * (la - mu) / K * nn + muvec = mu + phi * (la - mu) / K * nn } else if (ddep == 9) { - lavec = pmax(0, la * (mu / la) ^ (nn / K)) + y = log(la / mu) / K + lavec = pmax(0, la * exp(-nn * y)) muvec = rep(mu, lnn) } else if (ddep == 10) { + y = log(la / mu) / K lavec = rep(la, lnn) - muvec = mu * (la / mu) ^ (nn / K) + muvec = mu * exp(nn * y) } else if (ddep == 11) { - lavec = pmax(0, la - (1 - alpha) * (la - mu) * nn / K ) - muvec = mu * (1 + alpha * (la - mu) / mu) ^ (nn / K) + y = log((phi * la + (1 - phi) * mu) / mu) / K + lavec = pmax(0, la - (1 - phi) * (la - mu) * nn / K ) + muvec = mu * exp(nn * y) } else if (ddep == 12) { - lavec = pmax(0, la * ((alpha * (la - mu) + mu) / la) ^ (nn / K)) - muvec = mu * (1 + alpha * (la - mu) / mu) ^ (nn / K) + y1 = log(la / (phi * la + (1 - phi) * mu)) / K + y2 = log((phi * la + (1 - phi) * mu) / mu) / K + lavec = pmax(0, la * exp(-nn * y1)) + muvec = mu * exp(nn * y2) } else if (ddep == 13) { - lavec = pmax(0, la * ((alpha * (la - mu) + mu) / la) ^ (nn / K)) - muvec = mu + alpha * (la - mu) / K * nn + y = log(la / (phi * la + (1 - phi) * mu)) / K + lavec = pmax(0, la * exp(-nn * y)) + muvec = mu + phi * (la - mu) / K * nn } else if (ddep == 14) { - y = log(1 + alpha * (la - mu) / mu) / log(K) - lavec = pmax(0, la * ((alpha * (la - mu) + mu) / la) ^ (nn / K)) - muvec = mu * nn ^ y + y1 = log(la / (phi * la + (1 - phi) * mu)) / K + y2 = log(1 + phi * (la - mu) / mu) / log(K) + lavec = pmax(0, la * exp(-nn * y1)) + muvec = mu * nn ^ y2 } else if (ddep == 15) { - y = -log(la / (alpha * (la - mu) + mu)) / log(K) - lavec = pmax(0, la * nn ^ y) - muvec = mu * (1 + alpha * (la - mu) / mu) ^ (nn / K) + y1 = -log(la / (phi * (la - mu) + mu)) / log(K) + y2 = log((phi * la + (1 - phi) * mu) / mu) / K + lavec = pmax(0, la * nn ^ y1) + muvec = mu * exp(nn * y2) } return(c(lavec, muvec, nn)) } diff --git a/R/dd_sim.R b/R/dd_sim.R index eb594a0..995e096 100644 --- a/R/dd_sim.R +++ b/R/dd_sim.R @@ -53,28 +53,36 @@ dd_lamuN = function(ddmodel,pars,N) { laN = max(0, la * N ^ y) muN = mu + phi * (la - mu) / K * N } else if (ddmodel == 9) { - laN = max(0, la * (mu / la) ^ (N / K)) + y = log(la / mu) / K + laN = max(0, la * exp(-N * y)) muN = mu } else if (ddmodel == 10) { + y = log(la / mu) / K laN = la - muN = mu * (la / mu) ^ (N / K) + muN = mu * exp(N * y) } else if (ddmodel == 11) { + y = log((phi * la + (1 - phi) * mu) / mu) / K laN = max(0, la - (1 - phi) * (la - mu) / K * N) - muN = mu * (1 + phi * (la - mu) / mu) ^ (N / K) + muN = mu * exp(N * y) } else if (ddmodel == 12) { - laN = max(0, la * ((phi * (la - mu) + mu) / la) ^ (N / K)) - muN = mu * (1 + phi * (la - mu) / mu) ^ (N / K) + y1 = log(la / (phi * la + (1 - phi) * mu)) / K + y2 = log((phi * la + (1 - phi) * mu) / mu) / K + laN = max(0, la * exp(-N * y1)) + muN = mu * exp(N * y2) } else if (ddmodel == 13) { - laN = max(0, la * ((phi * (la - mu) + mu) / la) ^ (N / K)) + y = log(la / (phi * la + (1 - phi) * mu)) / K + laN = max(0, la * exp(-N * y)) muN = mu + phi * (la - mu) / K * N } else if (ddmodel == 14) { - y = log(1 + phi * (la - mu) / mu) / log(K) - laN = max(0, la * ((phi * (la - mu) + mu) / la) ^ (N / K)) - muN = mu * N ^ y + y1 = log(la / (phi * la + (1 - phi) * mu)) / K + y2 = log(1 + phi * (la - mu) / mu) / log(K) + laN = max(0, la * exp(-N * y1)) + muN = mu * N ^ y2 } else if (ddmodel == 15) { - y = -log(la / (phi * (la - mu) + mu)) / log(K) - laN = max(0, la * N ^ y) - muN = mu * (1 + phi * (la - mu) / mu) ^ (N / K) + y1 = -log(la / (phi * (la - mu) + mu)) / log(K) + y2 = log((phi * la + (1 - phi) * mu) / mu) / K + laN = max(0, la * N ^ y1) + muN = mu * exp(N * y2) } return(c(laN,muN)) } From 3c0850cabf999cdeaa86ee05d460b9ed98cf0e81 Mon Sep 17 00:00:00 2001 From: Theo Pannetier Date: Mon, 27 Sep 2021 14:47:37 +0200 Subject: [PATCH 36/49] rewrote power and expo models to show rate at equilibrium --- R/dd_loglik_M.R | 37 +++++++++++++++++++------------------ R/dd_loglik_rhs.R | 39 ++++++++++++++++++++------------------- R/dd_sim.R | 35 ++++++++++++++++++----------------- 3 files changed, 57 insertions(+), 54 deletions(-) diff --git a/R/dd_loglik_M.R b/R/dd_loglik_M.R index 5548219..b47d7f2 100644 --- a/R/dd_loglik_M.R +++ b/R/dd_loglik_M.R @@ -6,6 +6,7 @@ lambdamu = function(n,pars,ddep) K = pars[3] r = pars[4] phi <- ifelse(r == Inf, 1, r / (1 + r)) # else r/(1+r) is NaN + eq_rate <- phi * la + (1 - phi) * mu n0 = (ddep == 2 | ddep == 4) if(ddep == 1) { # linear DD on speciation (K = equilibrium diversity) @@ -43,27 +44,27 @@ lambdamu = function(n,pars,ddep) } else if (ddep == 5) { # linear DD on speciation # linear DD on extinction - lavec = pmax(0, la - (1 - phi) * (la - mu) * n / K) - muvec = mu + phi * (la - mu) * n / K + lavec = pmax(0, la - (la - eq_rate) * n / K) + muvec = mu + (eq_rate - mu) * n / K } else if (ddep == 6) { # linear DD on speciation # "exponential" DD on extinction (power function) - y = log(1 + phi * (la - mu) / mu) / log(K) - lavec = pmax(0, la - (1 - phi) * (la - mu) * n / K) + y = log(eq_rate / mu) / log(K) + lavec = pmax(0, la - (la - eq_rate) * n / K) muvec = mu * n ^ y } else if (ddep == 7) { # "exponential" DD on speciation (power function) # "exponential" DD on extinction (power function) - y1 = -log(la / (phi * (la - mu) + mu)) / log(K) - y2 = log(1 + phi * (la - mu) / mu) / log(K) + y1 = -log(la / eq_rate) / log(K) + y2 = log(eq_rate / mu) / log(K) lavec = pmax(0, la * n ^ y1) muvec = mu * n ^ y2 } else if (ddep == 8) { # "exponential" DD on speciation (power function) # linear DD on extinction - y = -log(la / (phi * (la - mu) + mu)) / log(K) + y = -log(la / eq_rate) / log(K) lavec = pmax(0, la * n ^ y) - muvec = mu + phi * (la - mu) / K * n + muvec = mu + (eq_rate - mu) / K * n } else if (ddep == 9) { # exponential DD on speciation (exponential function) # constant-rate extinction @@ -79,34 +80,34 @@ lambdamu = function(n,pars,ddep) } else if (ddep == 11) { # linear DD on speciation # exponential DD on extinction (exponential function) - y = log((phi * la + (1 - phi) * mu) / mu) / K - lavec = pmax(0, la - (1 - phi) * (la - mu) * n / K) + y = log(eq_rate / mu) / K + lavec = pmax(0, la - (la - eq_rate) * n / K) muvec = mu * exp(n * y) } else if (ddep == 12) { # exponential DD on speciation (exponential function) # exponential DD on extinction (exponential function) - y1 = log(la / (phi * la + (1 - phi) * mu)) / K - y2 = log((phi * la + (1 - phi) * mu) / mu) / K + y1 = log(la / eq_rate) / K + y2 = log(eq_rate / mu) / K lavec = pmax(0, la * exp(-n * y1)) muvec = mu * exp(n * y2) } else if (ddep == 13) { # exponential DD on speciation (exponential function) # linear DD on extinction - y = log(la / (phi * la + (1 - phi) * mu)) / K + y = log(la / eq_rate) / K lavec = pmax(0, la * exp(-n * y)) - muvec = mu + phi * (la - mu) * n / K + muvec = mu + (eq_rate - mu) * n / K } else if (ddep == 14) { # exponential DD on speciation (exponential function) # exponential DD on extinction (power function) - y1 = log(la / (phi * la + (1 - phi) * mu)) / K - y2 = log(1 + phi * (la - mu) / mu) / log(K) + y1 = log(la / eq_rate) / K + y2 = log(eq_rate / mu) / log(K) lavec = pmax(0, la * exp(-n * y1)) muvec = mu * n ^ y2 } else if (ddep == 15) { # exponential DD on speciation (power function) # exponential DD on extinction (exponential function) - y1 = -log(la / (phi * (la - mu) + mu)) / log(K) - y2 = log((phi * la + (1 - phi) * mu) / mu) / K + y1 = -log(la / eq_rate) / log(K) + y2 = log(eq_rate / mu) / K lavec = pmax(0, la * n ^ y1) muvec = mu * exp(n * y2) } diff --git a/R/dd_loglik_rhs.R b/R/dd_loglik_rhs.R index 823bae1..2ddcf3a 100644 --- a/R/dd_loglik_rhs.R +++ b/R/dd_loglik_rhs.R @@ -11,7 +11,8 @@ dd_loglik_rhs_precomp = function(pars,x) r = pars[4] kk = pars[5] ddep = pars[6] - phi <- ifelse(r == Inf, 1, r / (1 + r)) # else r/(1+r) can be NaN + phi = ifelse(r == Inf, 1, r / (1 + r)) # else r/(1+r) can be NaN + eq_rate = phi * la + (1 - phi) * mu } n0 = (ddep == 2 | ddep == 4) @@ -45,21 +46,21 @@ dd_loglik_rhs_precomp = function(pars,x) y = (log(la / mu) / log(K + n0)) ^ (ddep != 4.2) muvec = mu * (nn + n0) ^ y } else if (ddep == 5) { - lavec = pmax(0, la - (1 - phi) * (la - mu) * nn / K) - muvec = mu + phi * (la - mu) / K * nn + lavec = pmax(0, la - (la - eq_rate) * nn / K) + muvec = mu + (eq_rate - mu) / K * nn } else if (ddep == 6) { - y = log(1 + phi * (la - mu) / mu) / log(K) - lavec = pmax(0, la - (1 - phi) * (la - mu) * nn / K) + y = log(eq_rate / mu) / log(K) + lavec = pmax(0, la - (la - eq_rate) * nn / K) muvec = mu * nn ^ y } else if (ddep == 7) { - y1 = -log(la / (phi * (la - mu) + mu)) / log(K) - y2 = log(1 + phi * (la - mu) / mu) / log(K) + y1 = -log(la / eq_rate) / log(K) + y2 = log(eq_rate / mu) / log(K) lavec = pmax(0, la * nn ^ y1) muvec = mu * nn ^ y2 } else if (ddep == 8) { - y = -log(la / (phi * (la - mu) + mu)) / log(K) + y = -log(la / eq_rate) / log(K) lavec = pmax(0, la * nn ^ y) - muvec = mu + phi * (la - mu) / K * nn + muvec = mu + (eq_rate - mu) / K * nn } else if (ddep == 9) { y = log(la / mu) / K lavec = pmax(0, la * exp(-nn * y)) @@ -69,26 +70,26 @@ dd_loglik_rhs_precomp = function(pars,x) lavec = rep(la, lnn) muvec = mu * exp(nn * y) } else if (ddep == 11) { - y = log((phi * la + (1 - phi) * mu) / mu) / K - lavec = pmax(0, la - (1 - phi) * (la - mu) * nn / K ) + y = log(eq_rate / mu) / K + lavec = pmax(0, la - (la - eq_rate) * nn / K ) muvec = mu * exp(nn * y) } else if (ddep == 12) { - y1 = log(la / (phi * la + (1 - phi) * mu)) / K - y2 = log((phi * la + (1 - phi) * mu) / mu) / K + y1 = log(la / eq_rate) / K + y2 = log(eq_rate / mu) / K lavec = pmax(0, la * exp(-nn * y1)) muvec = mu * exp(nn * y2) } else if (ddep == 13) { - y = log(la / (phi * la + (1 - phi) * mu)) / K + y = log(la / eq_rate) / K lavec = pmax(0, la * exp(-nn * y)) - muvec = mu + phi * (la - mu) / K * nn + muvec = mu + (eq_rate - mu) / K * nn } else if (ddep == 14) { - y1 = log(la / (phi * la + (1 - phi) * mu)) / K - y2 = log(1 + phi * (la - mu) / mu) / log(K) + y1 = log(la / eq_rate) / K + y2 = log(eq_rate / mu) / log(K) lavec = pmax(0, la * exp(-nn * y1)) muvec = mu * nn ^ y2 } else if (ddep == 15) { - y1 = -log(la / (phi * (la - mu) + mu)) / log(K) - y2 = log((phi * la + (1 - phi) * mu) / mu) / K + y1 = -log(la / eq_rate) / log(K) + y2 = log(eq_rate / mu) / K lavec = pmax(0, la * nn ^ y1) muvec = mu * exp(nn * y2) } diff --git a/R/dd_sim.R b/R/dd_sim.R index 995e096..8c2099a 100644 --- a/R/dd_sim.R +++ b/R/dd_sim.R @@ -7,6 +7,7 @@ dd_lamuN = function(ddmodel,pars,N) { if (length(pars) == 4) { r = pars[4] phi <- ifelse(r == Inf, 1, r / (1 + r)) + eq_rate <- phi * la + (1 - phi) * mu } if (ddmodel == 1) { # linear dependence in speciation rate @@ -37,21 +38,21 @@ dd_lamuN = function(ddmodel,pars,N) { muN = mu * (N + n0)^al } else if (ddmodel == 5) { # linear dependence in speciation rate and extinction rate - laN = max(0, la - (1 - phi) * (la - mu) * N / K) - muN = mu + phi * (la - mu) * N / K + laN = max(0, la - (la - eq_rate) * N / K) + muN = mu + (eq_rate - mu) * N / K } else if (ddmodel == 6) { - y = log(1 + phi * (la - mu) / mu) / log(K) + y = log(eq_rate / mu) / log(K) laN = max(0, la - (1 - phi) * (la - mu) * N / K) muN = mu * N ^ y } else if (ddmodel == 7) { - y1 = -log(la / (phi * (la - mu) + mu)) / log(K) - y2 = log(1 + phi * (la - mu) / mu) / log(K) + y1 = -log(la / eq_rate) / log(K) + y2 = log(eq_rate / mu) / log(K) laN = max(0, la * N ^ y1) muN = mu * N ^ y2 } else if (ddmodel == 8) { - y = -log(la / (phi * (la - mu) + mu)) / log(K) + y = -log(la / eq_rate) / log(K) laN = max(0, la * N ^ y) - muN = mu + phi * (la - mu) / K * N + muN = mu + (eq_rate - mu) / K * N } else if (ddmodel == 9) { y = log(la / mu) / K laN = max(0, la * exp(-N * y)) @@ -61,26 +62,26 @@ dd_lamuN = function(ddmodel,pars,N) { laN = la muN = mu * exp(N * y) } else if (ddmodel == 11) { - y = log((phi * la + (1 - phi) * mu) / mu) / K - laN = max(0, la - (1 - phi) * (la - mu) / K * N) + y = log(eq_rate / mu) / K + laN = max(0, la - (la - eq_rate) / K * N) muN = mu * exp(N * y) } else if (ddmodel == 12) { - y1 = log(la / (phi * la + (1 - phi) * mu)) / K - y2 = log((phi * la + (1 - phi) * mu) / mu) / K + y1 = log(la / eq_rate) / K + y2 = log(eq_rate / mu) / K laN = max(0, la * exp(-N * y1)) muN = mu * exp(N * y2) } else if (ddmodel == 13) { - y = log(la / (phi * la + (1 - phi) * mu)) / K + y = log(la / eq_rate) / K laN = max(0, la * exp(-N * y)) - muN = mu + phi * (la - mu) / K * N + muN = mu + (eq_rate - mu) / K * N } else if (ddmodel == 14) { - y1 = log(la / (phi * la + (1 - phi) * mu)) / K - y2 = log(1 + phi * (la - mu) / mu) / log(K) + y1 = log(la / eq_rate) / K + y2 = log(eq_rate / mu) / log(K) laN = max(0, la * exp(-N * y1)) muN = mu * N ^ y2 } else if (ddmodel == 15) { - y1 = -log(la / (phi * (la - mu) + mu)) / log(K) - y2 = log((phi * la + (1 - phi) * mu) / mu) / K + y1 = -log(la / eq_rate) / log(K) + y2 = log(eq_rate / mu) / K laN = max(0, la * N ^ y1) muN = mu * exp(N * y2) } From 5bfd4c7f800b8bb746605fa2d36394b0945f299d Mon Sep 17 00:00:00 2001 From: Theo Pannetier Date: Thu, 30 Sep 2021 12:23:32 +0200 Subject: [PATCH 37/49] ddmodels 1 and 3 now tested as well --- R/dd_loglik.R | 2 +- tests/testthat/test_ddmodels.R | 36 +++++++++++++++------------- tests/testthat/test_pars_dd_loglik.R | 20 +++++++++++----- 3 files changed, 34 insertions(+), 24 deletions(-) diff --git a/R/dd_loglik.R b/R/dd_loglik.R index 25f66fe..2729f60 100644 --- a/R/dd_loglik.R +++ b/R/dd_loglik.R @@ -224,7 +224,7 @@ dd_loglik1 = function(pars1,pars2,brts,missnumspec,methode = 'odeint::runge_kutt } else if (la == 0) { if (verbose) cat('la0 cannot be zero.\n') loglik = -Inf - } else if (ddep %in% c(2, 2.1, 2.2, 4, 6, 7, 10:12) && mu == 0) { + } else if (ddep %in% c(2, 2.1, 2.2, 4, 6, 7, 10:12, 14:15) && mu == 0) { if (verbose) cat('mu0 cannot be exactly zero for this model.\n') loglik = -Inf } else if (ddep == 8 && mu == 0 && r == 0) { diff --git a/tests/testthat/test_ddmodels.R b/tests/testthat/test_ddmodels.R index df2e2d5..ef71d2b 100644 --- a/tests/testthat/test_ddmodels.R +++ b/tests/testthat/test_ddmodels.R @@ -1,8 +1,5 @@ context("test_ddmodels") -# I do not test models 1 through 4; these have been implemented for a long time -# and I assume they have been thoroughly tested - # Case 1.: 0 < r < Inf (or 0 < phi < 1) pars_set1 <- c( "lambda_0" = 0.8, @@ -10,11 +7,10 @@ pars_set1 <- c( "K" = 20, "r" = 1/3 # corresponds to phi = 1/4 ) -# cat(paste("Testing ddmodels with lambda_0 =", pars_set1[1], "mu_0 =", pars_set1[2], "K =", pars_set1[3],"phi =", round(pars_set1[4], 3), "\n")) # Rates obtained on paper exptd_rates_set1 <- list( - #"lambda_cst" = function(N) 0.8, # not with phi != 1 - #"mu_cst" = function(N) 0.2, # not with phi != 0 + "lambda_cst" = function(N) 0.8, # not with phi != 1 + "mu_cst" = function(N) 0.2, # not with phi != 0 "lambda_lin" = function(N) pmax(0.8 - 0.0225 * N, 0), "mu_lin" = function(N) 0.2 + 0.0075 * N, "lambda_pow" = function(N) pmax(0.8 * N ^ (-log(0.8 / 0.35) / log(20)), 0), @@ -31,8 +27,8 @@ pars_set2 <- c( "r" = 0 ) exptd_rates_set2 <- list( - #"lambda_cst" = function(N) 0.8, # not with phi != 1 - #"mu_cst" = function(N) 0.2, # not with phi != 0 + "lambda_cst" = function(N) rep(0.8, length(N)), # not with phi != 1 + "mu_cst" = function(N) rep(0.2, length(N)), # not with phi != 0 "lambda_lin" = function(N) pmax(0.8 - 0.03 * N, 0), "mu_lin" = function(N) rep(0.2, length(N)), "lambda_pow" = function(N) pmax(0.8 * N ^ (-log(4) / log(20)), 0), @@ -48,8 +44,8 @@ pars_set3 <- c( "r" = Inf ) exptd_rates_set3 <- list( - #"lambda_cst" = function(N) 0.8, # not with phi != 1 - #"mu_cst" = function(N) 0.2, # not with phi != 0 + "lambda_cst" = function(N) rep(0.8, length(N)), # not with phi != 1 + "mu_cst" = function(N) rep(0.2, length(N)), # not with phi != 0 "lambda_lin" = function(N) rep(0.8, length(N)), "mu_lin" = function(N) 0.2 + 0.03 * N, "lambda_pow" = function(N) rep(0.8, length(N)), @@ -59,17 +55,20 @@ exptd_rates_set3 <- list( ) # Declare test functions -## Match a ddmodel digit with a set of speciation and extinction function -## See example below in exptd_rates_set1 +## Match a ddmodel with the corresponding pair of speciation and extinction functions match_exptd_rates <- function(ddmodel, exptd_rates_set, n_seq) { rates_ls <- switch( as.character(ddmodel), + "1" = list("la_N" = exptd_rates_set$lambda_lin(n_seq), "mu_N" = exptd_rates_set$mu_cst(n_seq)), + "2" = list("la_N" = exptd_rates_set$lambda_pow(n_seq), "mu_N" = exptd_rates_set$mu_cst(n_seq)), + "3" = list("la_N" = exptd_rates_set$lambda_cst(n_seq), "mu_N" = exptd_rates_set$mu_lin(n_seq)), + "4" = list("la_N" = exptd_rates_set$lambda_cst(n_seq), "mu_N" = exptd_rates_set$mu_pow(n_seq)), "5" = list("la_N" = exptd_rates_set$lambda_lin(n_seq), "mu_N" = exptd_rates_set$mu_lin(n_seq)), "6" = list("la_N" = exptd_rates_set$lambda_lin(n_seq), "mu_N" = exptd_rates_set$mu_pow(n_seq)), "7" = list("la_N" = exptd_rates_set$lambda_pow(n_seq), "mu_N" = exptd_rates_set$mu_pow(n_seq)), "8" = list("la_N" = exptd_rates_set$lambda_pow(n_seq), "mu_N" = exptd_rates_set$mu_lin(n_seq)), - #"9" = list("la_N" = exptd_rates_set$lambda_exp(n_seq), "mu_N" = exptd_rates_set$mu_cst(n_seq)), - #"10" = list("la_N" = exptd_rates_set$lambda_cst(n_seq), "mu_N" = exptd_rates_set$mu_exp(n_seq)), + "9" = list("la_N" = exptd_rates_set$lambda_exp(n_seq), "mu_N" = exptd_rates_set$mu_cst(n_seq)), + "10" = list("la_N" = exptd_rates_set$lambda_cst(n_seq), "mu_N" = exptd_rates_set$mu_exp(n_seq)), "11" = list("la_N" = exptd_rates_set$lambda_lin(n_seq), "mu_N" = exptd_rates_set$mu_exp(n_seq)), "12" = list("la_N" = exptd_rates_set$lambda_exp(n_seq), "mu_N" = exptd_rates_set$mu_exp(n_seq)), "13" = list("la_N" = exptd_rates_set$lambda_exp(n_seq), "mu_N" = exptd_rates_set$mu_lin(n_seq)), @@ -78,6 +77,7 @@ match_exptd_rates <- function(ddmodel, exptd_rates_set, n_seq) { ) return(rates_ls) } + ## Test function; compare DDD output with rates obtained on paper test_dd_loglik_rhs_precomp <- function(ddmodel, pars_set, exptd_rates_set) { # global variables @@ -94,6 +94,7 @@ test_dd_loglik_rhs_precomp <- function(ddmodel, pars_set, exptd_rates_set) { ddd_output <- dd_loglik_rhs_precomp( pars = c("pars" = pars_set, "k" = N, "ddmodel" = ddmodel), x = x ) + names(ddd_output) <- NULL ddd_rates <- list("la_N" = ddd_output[1:lnn], "mu_N" = ddd_output[(lnn + 1):(2 * lnn)]) # Test cat(paste("Testing ddmodel =", ddmodel, "\n")) @@ -114,6 +115,8 @@ test_lambdamu <- function(ddmodel, pars_set, exptd_rates_set) { ) ddd_rates <- lambdamu(n = n_seq, pars = pars_set, ddep = ddmodel) names(ddd_rates) <- c("la_N", "mu_N") + names(ddd_rates$la_N) <- NULL + names(ddd_rates$mu_N) <- NULL # Test cat(paste("Testing ddmodel =", ddmodel, "\n")) expect_equal(ddd_rates, exptd_rates) @@ -145,7 +148,6 @@ test_dd_lamuN <- function(ddmodel, pars_set, exptd_rates_set) { test_that("set1", { ddmodels <- c(5:8, 11:15) - invisible(lapply( ddmodels, test_dd_loglik_rhs_precomp, @@ -167,7 +169,7 @@ test_that("set1", { }) test_that("set2", { - ddmodels <- c(5:8, 11:15) + ddmodels <- c(1, 5:9, 11:15) invisible(lapply( ddmodels, test_dd_loglik_rhs_precomp, @@ -189,7 +191,7 @@ test_that("set2", { }) test_that("set3", { - ddmodels <- c(5:8, 11:15) + ddmodels <- c(3, 5:8, 10:15) invisible(lapply( ddmodels, test_dd_loglik_rhs_precomp, diff --git a/tests/testthat/test_pars_dd_loglik.R b/tests/testthat/test_pars_dd_loglik.R index 7556906..5439ef6 100644 --- a/tests/testthat/test_pars_dd_loglik.R +++ b/tests/testthat/test_pars_dd_loglik.R @@ -7,7 +7,7 @@ phylo <- dd_sim( )$tes brts <- ape::branching.times(phylo) -# Test function +# Shortcut function run_dd_loglik <- function(ddmodel, lambda_0 = 0.8, mu_0 = 0.1, K = 20, r = 1, verbose = FALSE) { if (both_rates_vary(ddmodel)) { pars1 <- c(lambda_0, mu_0, K, r) @@ -38,7 +38,7 @@ test_that("all DD models return a likelihood", { expect_silent(logL_dd6 <- run_dd_loglik(ddmodel = 6)) expect_true(logL_dd6 < 0 && is.finite(logL_dd6)) expect_silent(logL_dd7 <- run_dd_loglik(ddmodel = 7)) - expect_true(logL_dd7 < 7 && is.finite(logL_dd7)) + expect_true(logL_dd7 < 0 && is.finite(logL_dd7)) expect_silent(logL_dd8 <- run_dd_loglik(ddmodel = 8)) expect_true(logL_dd8 < 0 && is.finite(logL_dd8)) expect_silent(logL_dd9 <- run_dd_loglik(ddmodel = 9)) @@ -51,13 +51,19 @@ test_that("all DD models return a likelihood", { expect_true(logL_dd12 < 0 && is.finite(logL_dd12)) expect_silent(logL_dd13 <- run_dd_loglik(ddmodel = 13)) expect_true(logL_dd13 < 0 && is.finite(logL_dd13)) + expect_silent(logL_dd14 <- run_dd_loglik(ddmodel = 14)) + expect_true(logL_dd14 < 0 && is.finite(logL_dd14)) + expect_silent(logL_dd15 <- run_dd_loglik(ddmodel = 15)) + expect_true(logL_dd15 < 0 && is.finite(logL_dd15)) }) -test_that("ddmodel = 1 ok", { - # expect_equal(run_dd_loglik(ddmodel = 1, lambda_0 = 500,verbose = TRUE), -Inf) # also -Inf with 1000 - # run_dd_loglik(ddmodel = 1, lambda_0 = 300) # NAs / NaNs introduced, not solved +test_that("forbidden parameter values are handled properly", { + expect_equal(run_dd_loglik(ddmodel = 1, lambda_0 = 10000), -Inf) # Negative parameters are not allowed expect_equal(run_dd_loglik(ddmodel = 1, lambda_0 = -1), -Inf) + expect_equal(run_dd_loglik(ddmodel = 5, mu_0 = -1), -Inf) + expect_equal(run_dd_loglik(ddmodel = 1, K = -1), -Inf) + expect_equal(run_dd_loglik(ddmodel = 15, r = -1), -Inf) # lambda0 = mu0 not allowed expect_equal(run_dd_loglik(ddmodel = 1, lambda_0 = 0.8, mu_0 = 0.8), -Inf) expect_equal(run_dd_loglik(ddmodel = 1, lambda_0 = 0, mu_0 = 0, K = 0), -Inf) @@ -68,13 +74,15 @@ test_that("ddmodel = 1 ok", { expect_silent(run_dd_loglik(ddmodel = 5, K = 8)) # Exponential-DD extinction must have mu0 > 0 or result is NaN expect_equal(run_dd_loglik(ddmodel = 4, mu_0 = 0), -Inf) - expect_equal(run_dd_loglik(ddmodel = 6, mu_0 = 0), -Inf) + expect_equal(run_dd_loglik(ddmodel = 6, mu_0 = 0), -Inf) expect_equal(run_dd_loglik(ddmodel = 7, mu_0 = 0), -Inf) # Exponential-DD speciation must have either mu0 > 0 or r > 0 or result is NaN expect_equal(run_dd_loglik(ddmodel = 2, mu_0 = 0), -Inf) expect_equal(run_dd_loglik(ddmodel = 8, mu_0 = 0, r = 0), -Inf) + expect_equal(run_dd_loglik(ddmodel = 14, mu_0 = 0, r = 0), -Inf) # Exponential(alternative)-DD extinction must have mu0 > 0 or result is NaN expect_equal(run_dd_loglik(ddmodel = 10, mu_0 = 0), -Inf) expect_equal(run_dd_loglik(ddmodel = 11, mu_0 = 0), -Inf) expect_equal(run_dd_loglik(ddmodel = 12, mu_0 = 0), -Inf) + expect_equal(run_dd_loglik(ddmodel = 15, mu_0 = 0, r = 0), -Inf) }) \ No newline at end of file From fbc8013235e624d92dc7cbf26cace0b9e79638ca Mon Sep 17 00:00:00 2001 From: Theo Pannetier Date: Mon, 8 Nov 2021 15:41:38 +0100 Subject: [PATCH 38/49] some automatic Rcpp addition I suppose --- src/RcppExports.cpp | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/RcppExports.cpp b/src/RcppExports.cpp index a89192c..9b20a26 100644 --- a/src/RcppExports.cpp +++ b/src/RcppExports.cpp @@ -5,6 +5,11 @@ using namespace Rcpp; +#ifdef RCPP_USE_GLOBAL_ROSTREAM +Rcpp::Rostream& Rcpp::Rcout = Rcpp::Rcpp_cout_get(); +Rcpp::Rostream& Rcpp::Rcerr = Rcpp::Rcpp_cerr_get(); +#endif + // dd_integrate_bw_odeint NumericVector dd_integrate_bw_odeint(NumericVector ry, NumericVector times, NumericVector pars, double atol, double rtol, std::string stepper); RcppExport SEXP _DDD_dd_integrate_bw_odeint(SEXP rySEXP, SEXP timesSEXP, SEXP parsSEXP, SEXP atolSEXP, SEXP rtolSEXP, SEXP stepperSEXP) { From 23880bfacb882f80cb9744930f39a5a684a5f0ea Mon Sep 17 00:00:00 2001 From: rsetienne Date: Mon, 15 Nov 2021 15:24:39 +0100 Subject: [PATCH 39/49] Reduce lx when diversification rate drops below -100 --- R/dd_loglik.R | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/R/dd_loglik.R b/R/dd_loglik.R index 2729f60..9d740a4 100644 --- a/R/dd_loglik.R +++ b/R/dd_loglik.R @@ -206,8 +206,10 @@ dd_loglik1 = function(pars1,pars2,brts,missnumspec,methode = 'odeint::runge_kutt } } - lx = min(max(1 + missnumspec, 1 + Kprime), ceiling(pars2[1])) - + lx <- min(max(1 + missnumspec, 1 + Kprime), ceiling(pars2[1])) + ff <- lambdamu(1:lx, pars1, ddep) + lx <- min(which(ff[[1]] - ff[[2]] < -100), lx) + if ((ddep == 1) & ((mu == 0 & missnumspec == 0 & floor(K) != ceiling(K) & la > 0.05) | K == Inf)) { loglik = bd_loglik(pars1[1:(2 + (K < Inf))],c(2*(mu == 0 & K < Inf),pars2[3:6]),brts,missnumspec) } else { @@ -393,9 +395,9 @@ dd_loglik2 = function(pars1,pars2,brts,missnumspec) pars2[6] = 2 } ddep = pars2[2] - if (ddep > 5) { - stop("This DD model is not implemented for the analytical method yet.") - } + #if (ddep > 5) { + # stop("This DD model is not implemented for the analytical method yet.") + #} cond = pars2[3] btorph = pars2[4] verbose <- pars2[5] From 65c3ef35666b9e6332c966cc1c19d31d61ba6b66 Mon Sep 17 00:00:00 2001 From: rsetienne Date: Wed, 17 Nov 2021 09:00:12 +0100 Subject: [PATCH 40/49] Changed from difference to ratio --- R/dd_loglik.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/dd_loglik.R b/R/dd_loglik.R index 9d740a4..c941563 100644 --- a/R/dd_loglik.R +++ b/R/dd_loglik.R @@ -208,7 +208,7 @@ dd_loglik1 = function(pars1,pars2,brts,missnumspec,methode = 'odeint::runge_kutt lx <- min(max(1 + missnumspec, 1 + Kprime), ceiling(pars2[1])) ff <- lambdamu(1:lx, pars1, ddep) - lx <- min(which(ff[[1]] - ff[[2]] < -100), lx) + lx <- min(which(ff[[2]]/ff[[1]] > 100), lx) if ((ddep == 1) & ((mu == 0 & missnumspec == 0 & floor(K) != ceiling(K) & la > 0.05) | K == Inf)) { loglik = bd_loglik(pars1[1:(2 + (K < Inf))],c(2*(mu == 0 & K < Inf),pars2[3:6]),brts,missnumspec) From bc07dbc8e03b59ae7b0d5170502150e6d04dd21d Mon Sep 17 00:00:00 2001 From: Theo Pannetier Date: Wed, 17 Nov 2021 13:04:14 +0100 Subject: [PATCH 41/49] version increment to track which solution is being used; 5.0.1 is on new-ddmodels-tmp --- DESCRIPTION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/DESCRIPTION b/DESCRIPTION index 572523f..1f63dc6 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,7 +1,7 @@ Package: DDD Type: Package Title: Diversity-Dependent Diversification -Version: 5.0 +Version: 5.0.2 Date: 2021-09-10 Depends: R (>= 3.5.0) Imports: deSolve, ape, phytools, subplex, Matrix, expm, SparseM, Rcpp (>= 1.0.5) From c5d95f780dec1ccfd0ca2858f7ab7c35fb01eabb Mon Sep 17 00:00:00 2001 From: rsetienne Date: Wed, 19 Jan 2022 17:23:01 +0100 Subject: [PATCH 42/49] = -> <- --- R/dd_KI_loglik.R | 154 +++++++++++++++++++++++------------------------ 1 file changed, 77 insertions(+), 77 deletions(-) diff --git a/R/dd_KI_loglik.R b/R/dd_KI_loglik.R index 5efa169..9b4122e 100644 --- a/R/dd_KI_loglik.R +++ b/R/dd_KI_loglik.R @@ -85,11 +85,11 @@ #' @keywords models #' @examples #' -#' pars1 = c(0.25,0.12,25.51,1.0,0.16,8.61,9.8) -#' pars2 = c(200,1,0,18.8,1,2) -#' missnumspec = 0 -#' brtsM = c(25.2,24.6,24.0,22.5,21.7,20.4,19.9,19.7,18.8,17.1,15.8,11.8,9.7,8.9,5.7,5.2) -#' brtsS = c(9.6,8.6,7.4,4.9,2.5) +#' pars1 <- c(0.25,0.12,25.51,1.0,0.16,8.61,9.8) +#' pars2 <- c(200,1,0,18.8,1,2) +#' missnumspec <- 0 +#' brtsM <- c(25.2,24.6,24.0,22.5,21.7,20.4,19.9,19.7,18.8,17.1,15.8,11.8,9.7,8.9,5.7,5.2) +#' brtsS <- c(9.6,8.6,7.4,4.9,2.5) #' dd_KI_loglik(pars1,pars2,brtsM,brtsS,missnumspec) #' #' @export dd_KI_loglik @@ -102,46 +102,46 @@ dd_KI_loglik <- function(pars1, { if(length(pars2) == 4) { - pars2[5] = 0 - pars2[6] = 2 - pars2[7] = 1 + pars2[5] <- 0 + pars2[6] <- 2 + pars2[7] <- 1 } if(is.na(pars2[7])) { - pars2[7] = 0 + pars2[7] <- 0 } #pars2 <- as.data.frame(rbind(pars2)) - names(pars2) = c('lx','ddep','cond','t_split','verbose','soc','corr') - tinn = -abs(pars1[7]) - soc = pars2[6] + names(pars2) <- c('lx','ddep','cond','t_split','verbose','soc','corr') + tinn <- -abs(pars1[7]) + soc <- pars2[6] #pars2 <- as.vector(pars2) # order branching times - brts = -sort(abs(c(brtsM,brtsS)),decreasing = TRUE) + brts <- -sort(abs(c(brtsM,brtsS)),decreasing = TRUE) if(sum(brts == 0) == 0) { - brts[length(brts) + 1] = 0 + brts[length(brts) + 1] <- 0 } - S = length(brts) + (soc - 2) - brtsM = -sort(abs(brtsM),decreasing = TRUE) - brtsS = -sort(abs(brtsS),decreasing = TRUE) + S <- length(brts) + (soc - 2) + brtsM <- -sort(abs(brtsM),decreasing = TRUE) + brtsS <- -sort(abs(brtsS),decreasing = TRUE) tinn <- -abs(pars1[7]) if(!any(brtsM == 0)) { - brtsM = c(brtsM,0) + brtsM <- c(brtsM,0) } if(!any(brtsS == 0)) { - brtsS = c(brtsS,0) + brtsS <- c(brtsS,0) } if(!any(brtsS == tinn)) { - brtsS = c(tinn,brtsS) + brtsS <- c(tinn,brtsS) } # avoid coincidence of branching time and key innovation time - if(sum(abs(brtsM - tinn) < 1E-14) == 1) { tinn = tinn - 1E-8 } + if(sum(abs(brtsM - tinn) < 1E-14) == 1) { tinn <- tinn - 1E-8 } - ka = sum(brtsM < tinn) + ka <- sum(brtsM < tinn) brtsMtinn <- sort(c(tinn,brtsM),decreasing = FALSE) kvec <- c(soc:(soc + ka - 1), (soc + ka - 2):(soc + length(brtsMtinn) - 4), @@ -174,15 +174,15 @@ dd_KI_loglik <- function(pars1, if(pars2[5]) { - s1 = sprintf('Parameters: %f %f %f %f %f %f %f, ',pars1[1],pars1[2],pars1[3],pars1[4],pars1[5],pars1[6],pars1[7]) - s2 = sprintf('Loglikelihood: %f',loglik) + s1 <- sprintf('Parameters: %f %f %f %f %f %f %f, ',pars1[1],pars1[2],pars1[3],pars1[4],pars1[5],pars1[6],pars1[7]) + s2 <- sprintf('Loglikelihood: %f',loglik) cat(s1,s2,"\n",sep = "") utils::flush.console() } - loglik = as.numeric(loglik) + loglik <- as.numeric(loglik) if(is.nan(loglik) || is.na(loglik)) { - loglik = -Inf + loglik <- -Inf } return(loglik) } @@ -309,7 +309,7 @@ dd_KI_logliknorm <- function(brts_k_list, { if(cond == 0 || loglik == -Inf) { - logliknorm = 0 + logliknorm <- 0 } else { if(length(brts_k_list) > 2 && cond == 1) { @@ -326,101 +326,101 @@ dd_KI_logliknorm <- function(brts_k_list, tpres <- 0 # COMPUTE NORMALIZATION # compute survival probability of clade S - lx = lx_list[[2]] - nx = -1:lx + lx <- lx_list[[2]] + nx <- -1:lx lambdamu_nk <- lambdamu(nx,pars = c(pars1_list[[2]],0),ddep = ddep) lavec <- lambdamu_nk[[1]] muvec <- lambdamu_nk[[2]] - probs = rep(0,lx) # probs[1] = extinction probability - probs[2] = 1 # clade S starts with one species + probs <- rep(0,lx) # probs[1] = extinction probability + probs[2] <- 1 # clade S starts with one species if(methode != 'analytical') { - m1 = lavec[1:lx] * nx[1:lx] - m2 = muvec[3:(lx + 2)] * nx[3:(lx + 2)] - m3 = (lavec[2:(lx + 1)] + muvec[2:(lx + 1)]) * nx[2:(lx + 1)] + m1 <- lavec[1:lx] * nx[1:lx] + m2 <- muvec[3:(lx + 2)] * nx[3:(lx + 2)] + m3 <- (lavec[2:(lx + 1)] + muvec[2:(lx + 1)]) * nx[2:(lx + 1)] if (startsWith(methode, 'odeint::')) { - probs = dd_logliknorm1_odeint(probs, c(tinn,tpres), c(m1,m2,m3), abstol, reltol, methode) + probs <- dd_logliknorm1_odeint(probs, c(tinn,tpres), c(m1,m2,m3), abstol, reltol, methode) } else { - y = deSolve::ode(probs,c(tinn,tpres),dd_logliknorm_rhs1,c(m1,m2,m3),rtol = reltol,atol = abstol,method = methode) - probs = y[2,2:(lx+1)] + y <- deSolve::ode(probs,c(tinn,tpres),dd_logliknorm_rhs1,c(m1,m2,m3),rtol = reltol,atol = abstol,method = methode) + probs <- y[2,2:(lx+1)] } } else { - probs = dd_loglik_M(pars1_list[[2]],lx,0,ddep,tt = abs(tpres - tinn),probs) + probs <- dd_loglik_M(pars1_list[[2]],lx,0,ddep,tt = abs(tpres - tinn),probs) } - PS = 1 - probs[1] + PS <- 1 - probs[1] # compute survival probability of clade M - lx = lx_list[[1]] + lx <- lx_list[[1]] n <- -1:lx - nx1 = rep(n,lx + 2) - dim(nx1) = c(lx + 2,lx + 2) # row index = number of species in first group - nx2 = t(nx1) # column index = number of species in second group - nxt = nx1 + nx2 + nx1 <- rep(n,lx + 2) + dim(nx1) <- c(lx + 2,lx + 2) # row index = number of species in first group + nx2 <- t(nx1) # column index = number of species in second group + nxt <- nx1 + nx2 lambdamu_n <- lambdamu2(nxt,pars1_list[[1]],ddep) lavec <- lambdamu_n[[1]] muvec <- lambdamu_n[[2]] - probs = matrix(0,lx,lx) + probs <- matrix(0,lx,lx) # probs[1,1] = probability of extinction of both lineages # sum(probs[1:lx,1]) = probability of extinction of second lineage - probs[2,2] = 1 # clade M starts with two species + probs[2,2] <- 1 # clade M starts with two species # STEP 1: integrate from tcrown to tinn - dim(probs) = c(lx,lx) + dim(probs) <- c(lx,lx) if(methode != 'analytical') { - m1 = lavec[1:lx,2:(lx+1)] * nx1[1:lx,2:(lx+1)] - m2 = muvec[3:(lx+2),2:(lx+1)] * nx1[3:(lx+2),2:(lx+1)] - ma = lavec[2:(lx+1),2:(lx+1)] + muvec[2:(lx+1),2:(lx+1)] - m3 = ma * nx1[2:(lx+1),2:(lx+1)] - m4 = lavec[2:(lx+1),1:lx] * nx2[2:(lx+1),1:lx] - m5 = muvec[2:(lx+1),3:(lx+2)] * nx2[2:(lx+1),3:(lx+2)] - m6 = ma * nx2[2:(lx+1),2:(lx+1)] + m1 <- lavec[1:lx,2:(lx+1)] * nx1[1:lx,2:(lx+1)] + m2 <- muvec[3:(lx+2),2:(lx+1)] * nx1[3:(lx+2),2:(lx+1)] + ma <- lavec[2:(lx+1),2:(lx+1)] + muvec[2:(lx+1),2:(lx+1)] + m3 <- ma * nx1[2:(lx+1),2:(lx+1)] + m4 <- lavec[2:(lx+1),1:lx] * nx2[2:(lx+1),1:lx] + m5 <- muvec[2:(lx+1),3:(lx+2)] * nx2[2:(lx+1),3:(lx+2)] + m6 <- ma * nx2[2:(lx+1),2:(lx+1)] if (startsWith(methode, "odeint::")) { - probs = dd_logliknorm2_odeint(probs, c(tcrown,tinn), list(m1,m2,m3,m4,m5,m6), reltol, abstol, methode) + probs <- dd_logliknorm2_odeint(probs, c(tcrown,tinn), list(m1,m2,m3,m4,m5,m6), reltol, abstol, methode) } else { - dim(probs) = c(lx*lx,1) - y = deSolve::ode(probs,c(tcrown,tinn),dd_logliknorm_rhs2,list(m1,m2,m3,m4,m5,m6),rtol = reltol,atol = abstol, method = "ode45") - probs = y[2,2:(lx * lx + 1)] + dim(probs) <- c(lx*lx,1) + y <- deSolve::ode(probs,c(tcrown,tinn),dd_logliknorm_rhs2,list(m1,m2,m3,m4,m5,m6),rtol = reltol,atol = abstol, method = "ode45") + probs <- y[2,2:(lx * lx + 1)] } } else { - probs = dd_loglik_M2(pars = pars1_list[[1]],lx = lx,ddep = ddep,tt = abs(tinn - tcrown),p = probs) + probs <- dd_loglik_M2(pars = pars1_list[[1]],lx = lx,ddep = ddep,tt = abs(tinn - tcrown),p = probs) } - dim(probs) = c(lx,lx) - probs[1,1:lx] = 0 - probs[1:lx,1] = 0 + dim(probs) <- c(lx,lx) + probs[1,1:lx] <- 0 + probs[1:lx,1] <- 0 # STEP 2: transformation at tinn - nx1a = nx1[2:(lx+1),2:(lx+1)] - nx2a = nx2[2:(lx+1),2:(lx+1)] - probs = probs * nx1a/(nx1a+nx2a) - probs = rbind(probs[2:lx,1:lx], rep(0,lx)) + nx1a <- nx1[2:(lx+1),2:(lx+1)] + nx2a <- nx2[2:(lx+1),2:(lx+1)] + probs <- probs * nx1a/(nx1a+nx2a) + probs <- rbind(probs[2:lx,1:lx], rep(0,lx)) # STEP 3: integrate from tinn to tpres if(methode != 'analytical') { if (startsWith(methode, "odeint::")) { - probs = dd_logliknorm2_odeint(probs, c(tinn, tpres), list(m1,m2,m3,m4,m5,m6), reltol, abstol, 'odeint::runge_kutta_fehlberg78') + probs <- dd_logliknorm2_odeint(probs, c(tinn, tpres), list(m1,m2,m3,m4,m5,m6), reltol, abstol, 'odeint::runge_kutta_fehlberg78') } else { - dim(probs) = c(lx*lx,1) - y = deSolve::ode(probs,c(tinn, tpres),dd_logliknorm_rhs2,list(m1,m2,m3,m4,m5,m6),rtol = reltol,atol = abstol, method = "ode45") - probs = y[2,2:(lx * lx + 1)] - dim(probs) = c(lx,lx) + dim(probs) <- c(lx*lx,1) + y <- deSolve::ode(probs,c(tinn, tpres),dd_logliknorm_rhs2,list(m1,m2,m3,m4,m5,m6),rtol = reltol,atol = abstol, method = "ode45") + probs <- y[2,2:(lx * lx + 1)] + dim(probs) <- c(lx,lx) } } else { - probs = dd_loglik_M2(pars = pars1_list[[1]],lx = lx,ddep = ddep,tt = abs(tpres - tinn),p = probs) + probs <- dd_loglik_M2(pars = pars1_list[[1]],lx = lx,ddep = ddep,tt = abs(tpres - tinn),p = probs) } - dim(probs) = c(lx,lx) - PM12 = sum(probs[2:lx,2:lx]) - PM2 = sum(probs[1,2:lx]) + dim(probs) <- c(lx,lx) + PM12 <- sum(probs[2:lx,2:lx]) + PM2 <- sum(probs[1,2:lx]) #print(log(2) + log(PM12 + PS * PM2)) #print(log(2) + (log(PM12 + PM2) + log(PS))) #print(log(2) + (log(PM12) + log(PS))) - logliknorm = log(2) + (cond == 1) * log(PM12 + PS * PM2) + + logliknorm <- log(2) + (cond == 1) * log(PM12 + PS * PM2) + (cond == 4) * (log(PM12 + PM2) + log(PS)) + (cond == 5) * (log(PM12) + log(PS)) } @@ -538,7 +538,7 @@ check_for_impossible_pars <- function(pars1, #' the dynamics of main clades, potentially accompanied by a #' shift in parameters. #' @inheritParams dd_KI_loglik -#' @param pars1_list list of paramater sets one for each rate regime (subclade). +#' @param pars1_list list of parameter sets one for each rate regime (subclade). #' The parameters are: lambda (speciation rate), mu (extinction rate), and K #' (clade-level carrying capacity). #' @param brts_k_list list of matrices, one for each rate regime (subclade). Each From ae95556c57e44706d9f3eb299893893c1a6bd0d9 Mon Sep 17 00:00:00 2001 From: rsetienne Date: Wed, 19 Jan 2022 22:25:13 +0100 Subject: [PATCH 43/49] ddep 2.4 --- R/dd_loglik_M.R | 10 ++++++---- R/dd_loglik_rhs.R | 5 +++-- R/dd_utils.R | 5 +++-- 3 files changed, 12 insertions(+), 8 deletions(-) diff --git a/R/dd_loglik_M.R b/R/dd_loglik_M.R index b47d7f2..29ef7ec 100644 --- a/R/dd_loglik_M.R +++ b/R/dd_loglik_M.R @@ -18,10 +18,11 @@ lambdamu = function(n,pars,ddep) # constant-rate extinction lavec = pmax(0, la * (1 - n / K)) muvec = rep(mu, lnn) - } else if(ddep == 2 | ddep == 2.1 | ddep == 2.2) { + } else if(ddep == 2 | ddep == 2.1 | ddep == 2.2 | ddep == 2.4) { # "exponential" DD on speciation (power function) # constant-rate extinction - y = -(log(la / mu) / log(K + n0)) ^ (ddep != 2.2) + frac <- ifelse(ddep == 2.3, 0.1, la / mu) + y = -(log( frac ) / log(K + n0)) ^ (ddep != 2.2) lavec = pmax(0, la * (n + n0) ^ y) muvec = rep(mu, lnn) } else if(ddep == 2.3) { @@ -198,9 +199,10 @@ lambdamu2 = function(nxt,pars,ddep) { lavec = pmax(matrix(0,lnn,lnn),laM * (1 - nxt/KM)) muvec = muM * matrix(1,lnn,lnn) - } else if(ddep == 2 | ddep == 2.1 | ddep == 2.2) + } else if(ddep == 2 | ddep == 2.1 | ddep == 2.2 | ddep == 2.4) { - x = -(log(laM/muM)/log(KM+n0))^(ddep != 2.2) + fracM <- ifelse(ddep == 2.4, 0.1, laM/muM) + x = -(log( fracM )/log(KM + n0))^(ddep != 2.2) lavec = pmax(matrix(0,lnn,lnn),laM * (nxt + n0)^x) muvec = muM * matrix(1,lnn,lnn) } else if(ddep == 2.3) diff --git a/R/dd_loglik_rhs.R b/R/dd_loglik_rhs.R index 2ddcf3a..3dd73bb 100644 --- a/R/dd_loglik_rhs.R +++ b/R/dd_loglik_rhs.R @@ -30,8 +30,9 @@ dd_loglik_rhs_precomp = function(pars,x) } else if(ddep == 1.5) { lavec = pmax(0, la * nn / K * (1 - nn / K)) muvec = rep(mu, lnn) - } else if (ddep == 2 | ddep == 2.1 | ddep == 2.2) { - y = -(log(la / mu) / log(K + n0)) ^ (ddep != 2.2) + } else if (ddep == 2 | ddep == 2.1 | ddep == 2.2 | ddep == 2.4) { + frac <- ifelse(ddep == 2.4, 0.1, la / mu) + y = -(log( frac ) / log(K + n0)) ^ (ddep != 2.2) lavec = pmax(0, la * (nn + n0) ^ y) muvec = rep(mu, lnn) } else if(ddep == 2.3) { diff --git a/R/dd_utils.R b/R/dd_utils.R index f857a92..c8265e5 100644 --- a/R/dd_utils.R +++ b/R/dd_utils.R @@ -133,9 +133,10 @@ flavec2 = function(ddep,la,mu,K,r,lx,kk,n0) { lavec = pmax(rep(0,lx),la * nn/K * (1 - nn/K)) } - if(ddep == 2 | ddep == 2.1 | ddep == 2.2) + if(ddep == 2 | ddep == 2.1 | ddep == 2.2 | ddep == 2.4) { - x = -(log(la/mu)/log(K + n0))^(ddep != 2.2) + frac <- ifelse(ddep == 2.4, 0.1, la / mu) + x = -(log( frac )/log(K + n0))^(ddep != 2.2) lavec = pmax(rep(0,lx),la * (nn + n0)^x) } if(ddep == 2.3) From b3ca8ebc32a6aca569b7dfb1ddb9e13601aa00ee Mon Sep 17 00:00:00 2001 From: rsetienne Date: Fri, 21 Jan 2022 17:05:39 +0100 Subject: [PATCH 44/49] 0.1 -> 10 for ddmodel 2.4 --- R/dd_loglik_M.R | 2 +- R/dd_loglik_rhs.R | 2 +- R/dd_utils.R | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/R/dd_loglik_M.R b/R/dd_loglik_M.R index 29ef7ec..2184d92 100644 --- a/R/dd_loglik_M.R +++ b/R/dd_loglik_M.R @@ -201,7 +201,7 @@ lambdamu2 = function(nxt,pars,ddep) muvec = muM * matrix(1,lnn,lnn) } else if(ddep == 2 | ddep == 2.1 | ddep == 2.2 | ddep == 2.4) { - fracM <- ifelse(ddep == 2.4, 0.1, laM/muM) + fracM <- ifelse(ddep == 2.4, 10, laM/muM) x = -(log( fracM )/log(KM + n0))^(ddep != 2.2) lavec = pmax(matrix(0,lnn,lnn),laM * (nxt + n0)^x) muvec = muM * matrix(1,lnn,lnn) diff --git a/R/dd_loglik_rhs.R b/R/dd_loglik_rhs.R index 3dd73bb..fb2624f 100644 --- a/R/dd_loglik_rhs.R +++ b/R/dd_loglik_rhs.R @@ -31,7 +31,7 @@ dd_loglik_rhs_precomp = function(pars,x) lavec = pmax(0, la * nn / K * (1 - nn / K)) muvec = rep(mu, lnn) } else if (ddep == 2 | ddep == 2.1 | ddep == 2.2 | ddep == 2.4) { - frac <- ifelse(ddep == 2.4, 0.1, la / mu) + frac <- ifelse(ddep == 2.4, 10, la / mu) y = -(log( frac ) / log(K + n0)) ^ (ddep != 2.2) lavec = pmax(0, la * (nn + n0) ^ y) muvec = rep(mu, lnn) diff --git a/R/dd_utils.R b/R/dd_utils.R index c8265e5..bb17c1e 100644 --- a/R/dd_utils.R +++ b/R/dd_utils.R @@ -135,7 +135,7 @@ flavec2 = function(ddep,la,mu,K,r,lx,kk,n0) } if(ddep == 2 | ddep == 2.1 | ddep == 2.2 | ddep == 2.4) { - frac <- ifelse(ddep == 2.4, 0.1, la / mu) + frac <- ifelse(ddep == 2.4, 10, la / mu) x = -(log( frac )/log(K + n0))^(ddep != 2.2) lavec = pmax(rep(0,lx),la * (nn + n0)^x) } From a21b6d3c2c60e02052db7a00f829f86d1a75dd57 Mon Sep 17 00:00:00 2001 From: rsetienne Date: Mon, 24 Jan 2022 09:56:59 +0100 Subject: [PATCH 45/49] Exception for la = 0 or K = 0 --- R/dd_loglik.R | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/R/dd_loglik.R b/R/dd_loglik.R index c941563..357c45f 100644 --- a/R/dd_loglik.R +++ b/R/dd_loglik.R @@ -220,6 +220,10 @@ dd_loglik1 = function(pars1,pars2,brts,missnumspec,methode = 'odeint::runge_kutt brts[length(brts) + 1] = 0 } S = length(brts) + (soc - 2) + if ((la == 0 | K == 0) & S > soc) { + loglik <- -Inf + return(loglik) + } if (any(pars1 < 0)) { if (verbose) cat('Model parameters cannot be negative.\n') loglik = -Inf From a5e43b19ef0a51003cae034a188dfa997a745125 Mon Sep 17 00:00:00 2001 From: rsetienne Date: Mon, 24 Jan 2022 12:34:06 +0100 Subject: [PATCH 46/49] lx defined later --- R/dd_loglik.R | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/R/dd_loglik.R b/R/dd_loglik.R index 357c45f..2213e9d 100644 --- a/R/dd_loglik.R +++ b/R/dd_loglik.R @@ -206,10 +206,6 @@ dd_loglik1 = function(pars1,pars2,brts,missnumspec,methode = 'odeint::runge_kutt } } - lx <- min(max(1 + missnumspec, 1 + Kprime), ceiling(pars2[1])) - ff <- lambdamu(1:lx, pars1, ddep) - lx <- min(which(ff[[2]]/ff[[1]] > 100), lx) - if ((ddep == 1) & ((mu == 0 & missnumspec == 0 & floor(K) != ceiling(K) & la > 0.05) | K == Inf)) { loglik = bd_loglik(pars1[1:(2 + (K < Inf))],c(2*(mu == 0 & K < Inf),pars2[3:6]),brts,missnumspec) } else { @@ -224,6 +220,9 @@ dd_loglik1 = function(pars1,pars2,brts,missnumspec,methode = 'odeint::runge_kutt loglik <- -Inf return(loglik) } + lx <- min(max(1 + missnumspec, 1 + Kprime), ceiling(pars2[1])) + ff <- lambdamu(1:lx, pars1, ddep) + lx <- min(which(ff[[2]]/ff[[1]] > 100), lx) if (any(pars1 < 0)) { if (verbose) cat('Model parameters cannot be negative.\n') loglik = -Inf From 3ff3f8e28e28123bf709638711f2bddf34a5b1ba Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Pannetier?= Date: Mon, 5 Dec 2022 18:36:06 +0100 Subject: [PATCH 47/49] rm outdated commented line --- tests/testthat/test_DDD.R | 1 - 1 file changed, 1 deletion(-) diff --git a/tests/testthat/test_DDD.R b/tests/testthat/test_DDD.R index 60fc9a4..6ddb6dc 100644 --- a/tests/testthat/test_DDD.R +++ b/tests/testthat/test_DDD.R @@ -1,6 +1,5 @@ context("test_DDD") -# file named z_DDD so tests run last test_that("DDD works", { expect_equal_x64 <- function(object, expected, ...) { From ddb0d7a7590ad520f93179e48dda321dc83b5cab Mon Sep 17 00:00:00 2001 From: Theo Pannetier Date: Mon, 5 Dec 2022 18:44:21 +0100 Subject: [PATCH 48/49] revert changes to tests I can't recall making for a good reason --- tests/testthat/test_DDD.R | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/tests/testthat/test_DDD.R b/tests/testthat/test_DDD.R index 60fc9a4..8489744 100644 --- a/tests/testthat/test_DDD.R +++ b/tests/testthat/test_DDD.R @@ -21,9 +21,9 @@ test_that("DDD works", { methode = 'analytical' r0 <- dd_loglik(pars1 = pars1,pars2 = pars2,brts = brts,missnumspec = missnumspec,methode = methode) - r1 <- dd_loglik(pars1 = pars1,pars2 = pars2,brts = brts,missnumspec = missnumspec,methode = methode) - r2 <- dd_loglik(pars1 = pars1,pars2 = pars2,brts = brts,missnumspec = missnumspec,methode = methode) - r3 <- dd_loglik(pars1 = pars1,pars2 = pars2,brts = brts,missnumspec = missnumspec,methode = 'analytical') + r1 <- dd_loglik_test(pars1 = pars1,pars2 = pars2,brts = brts,missnumspec = missnumspec,rhs_func_name = 'dd_loglik_rhs',methode = methode) + r2 <- dd_loglik_test(pars1 = pars1,pars2 = pars2,brts = brts,missnumspec = missnumspec,rhs_func_name = 'dd_loglik_rhs_FORTRAN',methode = methode) + r3 <- dd_loglik_test(pars1 = pars1,pars2 = pars2,brts = brts,missnumspec = missnumspec,methode = 'analytical') testthat::expect_equal(r0,r2,tolerance = .00001) testthat::expect_equal(r1,r2,tolerance = .00001) @@ -36,8 +36,8 @@ test_that("DDD works", { brts = 1:5 pars2 = c(100,1,3,0,0,2) r5 <- dd_loglik(pars1 = pars1,pars2 = pars2,brts = brts,missnumspec = missnumspec,methode = methode) - r6 <- dd_loglik(pars1 = pars1,pars2 = pars2,brts = brts,missnumspec = missnumspec,methode = methode) - r7 <- dd_loglik(pars1 = pars1,pars2 = pars2,brts = brts,missnumspec = missnumspec,methode = 'analytical') + r6 <- dd_loglik_test(pars1 = pars1,pars2 = pars2,brts = brts,missnumspec = missnumspec,rhs_func_name = 'dd_loglik_bw_rhs',methode = methode) + r7 <- dd_loglik_test(pars1 = pars1,pars2 = pars2,brts = brts,missnumspec = missnumspec,rhs_func_name = 'dd_loglik_bw_rhs_FORTRAN',methode = 'analytical') testthat::expect_equal(r5,r6,tolerance = .00001) testthat::expect_equal(r5,r7,tolerance = .01) From bb6886ffdbc905c043e5171898e8ce864310fa51 Mon Sep 17 00:00:00 2001 From: Theo Pannetier Date: Wed, 7 Dec 2022 15:13:34 +0100 Subject: [PATCH 49/49] fix doc + new helper to convert ddmodel to description --- DESCRIPTION | 2 +- NAMESPACE | 1 + R/dd_loglik.R | 5 + R/dd_utils.R | 583 +++++++++++++++++++---------------- man/dd_KI_loglik.Rd | 10 +- man/dd_SR_ML.Rd | 4 +- man/dd_loglik.Rd | 5 + man/dd_multiple_KI_loglik.Rd | 2 +- man/what_is_this_ddmodel.Rd | 24 ++ 9 files changed, 365 insertions(+), 271 deletions(-) create mode 100644 man/what_is_this_ddmodel.Rd diff --git a/DESCRIPTION b/DESCRIPTION index 2776438..2e5ba4e 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -24,4 +24,4 @@ Description: . Also contains functions to simulate the diversity-dependent process. -RoxygenNote: 7.1.2 +RoxygenNote: 7.2.2 diff --git a/NAMESPACE b/NAMESPACE index 9ecdfe1..dfbf89a 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -30,4 +30,5 @@ export(simplex) export(td_sim) export(transform_pars) export(untransform_pars) +export(what_is_this_ddmodel) useDynLib(DDD) diff --git a/R/dd_loglik.R b/R/dd_loglik.R index 2213e9d..b7dbd3f 100644 --- a/R/dd_loglik.R +++ b/R/dd_loglik.R @@ -120,6 +120,11 @@ dd_loglik_test = function(pars1,pars2,brts,missnumspec,methode = 'analytical',rh #' speciation and extinction\cr #' \cr - \code{pars2[2] == 13} exponential dependence (exponential function) in #' speciation, linear dependence in extinction \cr +#' \cr - \code{pars2[2] == 14} exponential dependence (exponential function) in +#' speciation, exponential dependence (power function) in extinction \cr +#' \cr - \code{pars2[2] == 15} exponential dependence (power function) in +#' speciation, exponential dependence (exponential function) in extinction \cr +#' #' \cr \cr \code{pars2[3]} sets the conditioning: #' \cr - \code{pars2[3] == 0} conditioning on stem or crown age #' \cr - \code{pars2[3] == 1} conditioning on stem or crown age and diff --git a/R/dd_utils.R b/R/dd_utils.R index bb9e542..c3d50ce 100644 --- a/R/dd_utils.R +++ b/R/dd_utils.R @@ -24,11 +24,11 @@ brts2phylo <- function(times,root=FALSE,tip.label=NULL) n <- n-1 } nbr <- 2*n - 2 - + # create the data types for edges and edge-lengths edge <- matrix(NA, nbr, 2) edge.length <- numeric(nbr) - + h <- numeric(2*n - 1) # initialized with 0's pool <- 1:n # VERY VERY IMPORTANT: the root MUST have index n+1 !!! @@ -54,24 +54,24 @@ brts2phylo <- function(times,root=FALSE,tip.label=NULL) nextnode <- nextnode - 1L } } - + phy <- list(edge = edge, edge.length = edge.length) if (is.null(tip.label)) tip.label <- paste("t", 1:n, sep = "") phy$tip.label <- sample(tip.label) phy$Nnode <- n - 1L - + if ( root ) { phy$root.edge <- times[n] - times[n-1] phy$root <- times[n] - times[n-1] } - + class(phy) <- "phylo" - + phy <- ape::reorder.phylo(phy) ## to avoid crossings when converting with as.hclust: phy$edge[phy$edge[, 2] <= n, 2] <- 1:n - + return(phy) } @@ -94,17 +94,17 @@ brts2phylo <- function(times,root=FALSE,tip.label=NULL) #' @export conv conv = function(x,y) { - lx = length(x) - ly = length(y) - lxy = length(x) + length(y) - x = c(x,rep(0,lxy - lx)) - y = c(y,rep(0,lxy - ly)) - cvxy = rep(0,lxy) - for(i in 2:lxy) - { - cvxy[i] = crossprod(x[(i-1):1],y[1:(i-1)]) - } - return(cvxy[2:lxy]) + lx = length(x) + ly = length(y) + lxy = length(x) + length(y) + x = c(x,rep(0,lxy - lx)) + y = c(y,rep(0,lxy - ly)) + cvxy = rep(0,lxy) + for(i in 2:lxy) + { + cvxy[i] = crossprod(x[(i-1):1],y[1:(i-1)]) + } + return(cvxy[2:lxy]) } flavec <- function(ddep,la,mu,K,r,lx,kk) @@ -116,39 +116,39 @@ flavec <- function(ddep,la,mu,K,r,lx,kk) flavec2 = function(ddep,la,mu,K,r,lx,kk,n0) { - nn = (0:(lx - 1)) + kk - if(ddep == 1 | ddep == 5) - { - lavec = pmax(rep(0,lx),la - 1/(r + 1) * (la - mu)/K * nn) - } - if(ddep == 1.3) - { - lavec = pmax(rep(0,lx),la * (1 - nn/K)) - } - if(ddep == 1.4) - { - lavec = pmax(rep(0,lx),la * nn/(nn + K)) - } - if(ddep == 1.5) - { - lavec = pmax(rep(0,lx),la * nn/K * (1 - nn/K)) - } - if(ddep == 2 | ddep == 2.1 | ddep == 2.2 | ddep == 2.4) - { - frac <- ifelse(ddep == 2.4, 10, la / mu) - x = -(log( frac )/log(K + n0))^(ddep != 2.2) - lavec = pmax(rep(0,lx),la * (nn + n0)^x) - } - if(ddep == 2.3) - { - x = -K - lavec = pmax(rep(0,lx),la * (nn + n0)^x) - } - if(ddep == 3 | ddep == 4 | ddep == 4.1 | ddep == 4.2) - { - lavec = la * rep(1,lx) - } - return(lavec) + nn = (0:(lx - 1)) + kk + if(ddep == 1 | ddep == 5) + { + lavec = pmax(rep(0,lx),la - 1/(r + 1) * (la - mu)/K * nn) + } + if(ddep == 1.3) + { + lavec = pmax(rep(0,lx),la * (1 - nn/K)) + } + if(ddep == 1.4) + { + lavec = pmax(rep(0,lx),la * nn/(nn + K)) + } + if(ddep == 1.5) + { + lavec = pmax(rep(0,lx),la * nn/K * (1 - nn/K)) + } + if(ddep == 2 | ddep == 2.1 | ddep == 2.2 | ddep == 2.4) + { + frac <- ifelse(ddep == 2.4, 10, la / mu) + x = -(log( frac )/log(K + n0))^(ddep != 2.2) + lavec = pmax(rep(0,lx),la * (nn + n0)^x) + } + if(ddep == 2.3) + { + x = -K + lavec = pmax(rep(0,lx),la * (nn + n0)^x) + } + if(ddep == 3 | ddep == 4 | ddep == 4.1 | ddep == 4.2) + { + lavec = la * rep(1,lx) + } + return(lavec) } @@ -183,51 +183,51 @@ flavec2 = function(ddep,la,mu,K,r,lx,kk,n0) #' #' @export L2phylo L2phylo = function(L,dropextinct = T) -# makes a phylogeny out of a matrix with branching times, parent and daughter species, and extinction times + # makes a phylogeny out of a matrix with branching times, parent and daughter species, and extinction times { - L = L[order(abs(L[,3])),1:4] - age = L[1,1] - L[,1] = age - L[,1] - L[1,1] = -1 - notmin1 = which(L[,4] != -1) - L[notmin1,4] = age - L[notmin1,4] - if(dropextinct == T) - { - sall = which(L[,4] == -1) - tend = age - } else { - sall = which(L[,4] >= -1) - tend = (L[,4] == -1) * age + (L[,4] > -1) * L[,4] - } - L = L[,-4] - linlist = cbind(data.frame(L[sall,]),paste("t",abs(L[sall,3]),sep = ""),tend) - linlist[,4] = as.character(linlist[,4]) - names(linlist) = 1:5 - done = 0 - while(done == 0) - { - j = which.max(linlist[,1]) - daughter = linlist[j,3] - parent = linlist[j,2] - parentj = which(parent == linlist[,3]) - parentinlist = length(parentj) - if(parentinlist == 1) - { - spec1 = paste(linlist[parentj,4],":",linlist[parentj,5] - linlist[j,1],sep = "") - spec2 = paste(linlist[j,4],":",linlist[j,5] - linlist[j,1],sep = "") - linlist[parentj,4] = paste("(",spec1,",",spec2,")",sep = "") - linlist[parentj,5] = linlist[j,1] - linlist = linlist[-j,] - } else { - #linlist[j,1:3] = L[abs(as.numeric(parent)),1:3] - linlist[j,1:3] = L[which(L[,3] == parent),1:3] - } - if(nrow(linlist) == 1) { done = 1 } - } - linlist[4] = paste(linlist[4],":",linlist[5],";",sep = "") - phy = ape::read.tree(text = linlist[1,4]) - tree = ape::as.phylo(phy) - return(tree) + L = L[order(abs(L[,3])),1:4] + age = L[1,1] + L[,1] = age - L[,1] + L[1,1] = -1 + notmin1 = which(L[,4] != -1) + L[notmin1,4] = age - L[notmin1,4] + if(dropextinct == T) + { + sall = which(L[,4] == -1) + tend = age + } else { + sall = which(L[,4] >= -1) + tend = (L[,4] == -1) * age + (L[,4] > -1) * L[,4] + } + L = L[,-4] + linlist = cbind(data.frame(L[sall,]),paste("t",abs(L[sall,3]),sep = ""),tend) + linlist[,4] = as.character(linlist[,4]) + names(linlist) = 1:5 + done = 0 + while(done == 0) + { + j = which.max(linlist[,1]) + daughter = linlist[j,3] + parent = linlist[j,2] + parentj = which(parent == linlist[,3]) + parentinlist = length(parentj) + if(parentinlist == 1) + { + spec1 = paste(linlist[parentj,4],":",linlist[parentj,5] - linlist[j,1],sep = "") + spec2 = paste(linlist[j,4],":",linlist[j,5] - linlist[j,1],sep = "") + linlist[parentj,4] = paste("(",spec1,",",spec2,")",sep = "") + linlist[parentj,5] = linlist[j,1] + linlist = linlist[-j,] + } else { + #linlist[j,1:3] = L[abs(as.numeric(parent)),1:3] + linlist[j,1:3] = L[which(L[,3] == parent),1:3] + } + if(nrow(linlist) == 1) { done = 1 } + } + linlist[4] = paste(linlist[4],":",linlist[5],";",sep = "") + phy = ape::read.tree(text = linlist[1,4]) + tree = ape::as.phylo(phy) + return(tree) } @@ -385,52 +385,52 @@ phylo2L = function(phy) #' #' @export L2brts L2brts = function(L,dropextinct = T) -# makes a phylogeny out of a matrix with branching times, parent and daughter species, and extinction times + # makes a phylogeny out of a matrix with branching times, parent and daughter species, and extinction times { - brts = NULL - L = L[order(abs(L[,3])),1:4] - age = L[1,1] - L[,1] = age - L[,1] - L[1,1] = -1 - notmin1 = which(L[,4] != -1) - L[notmin1,4] = age - L[notmin1,4] - if(dropextinct == T) - { - sall = which(L[,4] == -1) - tend = age - } else { - sall = which(L[,4] >= -1) - tend = (L[,4] == -1) * age + (L[,4] > -1) * L[,4] - } - L = L[,-4] - linlist = cbind(data.frame(L[sall,]),paste("t",abs(L[sall,3]),sep = ""),tend) - linlist[,4] = as.character(linlist[,4]) - names(linlist) = 1:5 - done = 0 - while(done == 0) - { - j = which.max(linlist[,1]) - daughter = linlist[j,3] - parent = linlist[j,2] - parentj = which(parent == linlist[,3]) - parentinlist = length(parentj) - if(parentinlist == 1) - { - spec1 = paste(linlist[parentj,4],":",linlist[parentj,5] - linlist[j,1],sep = "") - spec2 = paste(linlist[j,4],":",linlist[j,5] - linlist[j,1],sep = "") - linlist[parentj,4] = paste("(",spec1,",",spec2,")",sep = "") - linlist[parentj,5] = linlist[j,1] - brts = c(brts,linlist[j,1]) - linlist = linlist[-j,] - } else { - #linlist[j,1:3] = L[abs(as.numeric(parent)),1:3] - linlist[j,1:3] = L[which(L[,3] == parent),1:3] - } - if(nrow(linlist) == 1) { done = 1 } - } - #linlist[4] = paste(linlist[4],":",linlist[5],";",sep = "") - brts = rev(sort(age - brts)) - return(brts) + brts = NULL + L = L[order(abs(L[,3])),1:4] + age = L[1,1] + L[,1] = age - L[,1] + L[1,1] = -1 + notmin1 = which(L[,4] != -1) + L[notmin1,4] = age - L[notmin1,4] + if(dropextinct == T) + { + sall = which(L[,4] == -1) + tend = age + } else { + sall = which(L[,4] >= -1) + tend = (L[,4] == -1) * age + (L[,4] > -1) * L[,4] + } + L = L[,-4] + linlist = cbind(data.frame(L[sall,]),paste("t",abs(L[sall,3]),sep = ""),tend) + linlist[,4] = as.character(linlist[,4]) + names(linlist) = 1:5 + done = 0 + while(done == 0) + { + j = which.max(linlist[,1]) + daughter = linlist[j,3] + parent = linlist[j,2] + parentj = which(parent == linlist[,3]) + parentinlist = length(parentj) + if(parentinlist == 1) + { + spec1 = paste(linlist[parentj,4],":",linlist[parentj,5] - linlist[j,1],sep = "") + spec2 = paste(linlist[j,4],":",linlist[j,5] - linlist[j,1],sep = "") + linlist[parentj,4] = paste("(",spec1,",",spec2,")",sep = "") + linlist[parentj,5] = linlist[j,1] + brts = c(brts,linlist[j,1]) + linlist = linlist[-j,] + } else { + #linlist[j,1:3] = L[abs(as.numeric(parent)),1:3] + linlist[j,1:3] = L[which(L[,3] == parent),1:3] + } + if(nrow(linlist) == 1) { done = 1 } + } + #linlist[4] = paste(linlist[4],":",linlist[5],";",sep = "") + brts = rev(sort(age - brts)) + return(brts) } @@ -459,9 +459,9 @@ L2brts = function(L,dropextinct = T) #' @export roundn roundn = function(x, digits = 0) { - fac = 10^digits - n = trunc(fac * x + 0.5)/fac - return(n) + fac = 10^digits + n = trunc(fac * x + 0.5)/fac + return(n) } @@ -490,21 +490,21 @@ roundn = function(x, digits = 0) #' @export sample2 sample2 = function(x,size,replace = FALSE,prob = NULL) { - if(length(x) == 1) - { - x = c(x,x) - prob = c(prob,prob) - if(is.null(size)) - { - size = 1 - } - if(replace == FALSE & size > 1) - { - stop('It is not possible to sample without replacement multiple times from a single item.') - } + if(length(x) == 1) + { + x = c(x,x) + prob = c(prob,prob) + if(is.null(size)) + { + size = 1 } - sam = sample(x,size,replace,prob) - return(sam) + if(replace == FALSE & size > 1) + { + stop('It is not possible to sample without replacement multiple times from a single item.') + } + } + sam = sample(x,size,replace,prob) + return(sam) } #' Carries out optimization using a simplex algorithm (finding a minimum) @@ -536,26 +536,26 @@ simplex = function(fun,trparsopt,optimpars,...) reltolf = optimpars[2] abstolx = optimpars[3] maxiter = optimpars[4] - + ## Setting up initial simplex v = t(matrix(rep(trparsopt,each = numpar + 1),nrow = numpar + 1)) for(i in 1:numpar) { - parsoptff = 1.05 * untransform_pars(trparsopt[i]) - trparsoptff = transform_pars(parsoptff) - fac = trparsoptff/trparsopt[i] - if(v[i,i + 1] == 0) - { - v[i,i + 1] = 0.00025 - } else { - v[i,i + 1] = v[i,i + 1] * min(1.05,fac) - } + parsoptff = 1.05 * untransform_pars(trparsopt[i]) + trparsoptff = transform_pars(parsoptff) + fac = trparsoptff/trparsopt[i] + if(v[i,i + 1] == 0) + { + v[i,i + 1] = 0.00025 + } else { + v[i,i + 1] = v[i,i + 1] * min(1.05,fac) + } } fv = rep(0,numpar + 1) for(i in 1:(numpar + 1)) { - fv[i] = -fun(trparsopt = v[,i], ...) + fv[i] = -fun(trparsopt = v[,i], ...) } how = "initial" @@ -563,7 +563,7 @@ simplex = function(fun,trparsopt,optimpars,...) string = itercount for(i in 1:numpar) { - string = paste(string, untransform_pars(v[i,1]), sep = " ") + string = paste(string, untransform_pars(v[i,1]), sep = " ") } string = paste(string, -fv[1], how, "\n", sep = " ") cat(string) @@ -572,9 +572,9 @@ simplex = function(fun,trparsopt,optimpars,...) tmp = order(fv) if(numpar == 1) { - v = matrix(v[tmp],nrow = 1,ncol = 2) + v = matrix(v[tmp],nrow = 1,ncol = 2) } else { - v = v[,tmp] + v = v[,tmp] } fv = fv[tmp] @@ -588,100 +588,100 @@ simplex = function(fun,trparsopt,optimpars,...) while(itercount <= maxiter & ( ( is.nan(max(abs(fv - fv[1]))) | (max(abs(fv - fv[1])) - reltolf * abs(fv[1]) > 0) ) + ( (max(abs(v - v2) - reltolx * abs(v2)) > 0) | (max(abs(v - v2)) - abstolx > 0) ) ) ) { - ## Calculate reflection point - - if(numpar == 1) - { - xbar = v[1] - } else { - xbar = rowSums(v[,1:numpar])/numpar - } - xr = (1 + rh) * xbar - rh * v[,numpar + 1] - fxr = -fun(trparsopt = xr, ...) - - if(fxr < fv[1]) - { - ## Calculate expansion point - xe = (1 + rh * ch) * xbar - rh * ch * v[,numpar + 1] - fxe = -fun(trparsopt = xe, ...) - if(fxe < fxr) - { - v[,numpar + 1] = xe - fv[numpar + 1] = fxe - how = "expand" - } else { - v[,numpar + 1] = xr - fv[numpar + 1] = fxr - how = "reflect" - } - } else { - if(fxr < fv[numpar]) - { - v[,numpar + 1] = xr - fv[numpar + 1] = fxr - how = "reflect" - } else { - if(fxr < fv[numpar + 1]) - { - ## Calculate outside contraction point - xco = (1 + ps * rh) * xbar - ps * rh * v[,numpar + 1] - fxco = -fun(trparsopt = xco, ...) - if(fxco <= fxr) - { - v[,numpar + 1] = xco - fv[numpar + 1] = fxco - how = "contract outside" - } else { - how = "shrink" - } - } else { - ## Calculate inside contraction point - xci = (1 - ps) * xbar + ps * v[,numpar + 1] - fxci = -fun(trparsopt = xci, ...) - if(fxci < fv[numpar + 1]) - { - v[,numpar + 1] = xci - fv[numpar + 1] = fxci - how = "contract inside" - } else { - how = "shrink" - } - } - if(how == "shrink") - { - for(j in 2:(numpar + 1)) - { - - v[,j] = v[,1] + si * (v[,j] - v[,1]) - fv[j] = -fun(trparsopt = v[,j], ...) - } - } - } - } - tmp = order(fv) - if(numpar == 1) - { - v = matrix(v[tmp],nrow = 1,ncol = 2) - } else { - v = v[,tmp] - } - fv = fv[tmp] - itercount = itercount + 1 - string = itercount; - for(i in 1:numpar) - { - string = paste(string, untransform_pars(v[i,1]), sep = " ") - } - string = paste(string, -fv[1], how, "\n", sep = " ") - cat(string) - utils::flush.console() - v2 = t(matrix(rep(v[,1],each = numpar + 1),nrow = numpar + 1)) + ## Calculate reflection point + + if(numpar == 1) + { + xbar = v[1] + } else { + xbar = rowSums(v[,1:numpar])/numpar + } + xr = (1 + rh) * xbar - rh * v[,numpar + 1] + fxr = -fun(trparsopt = xr, ...) + + if(fxr < fv[1]) + { + ## Calculate expansion point + xe = (1 + rh * ch) * xbar - rh * ch * v[,numpar + 1] + fxe = -fun(trparsopt = xe, ...) + if(fxe < fxr) + { + v[,numpar + 1] = xe + fv[numpar + 1] = fxe + how = "expand" + } else { + v[,numpar + 1] = xr + fv[numpar + 1] = fxr + how = "reflect" + } + } else { + if(fxr < fv[numpar]) + { + v[,numpar + 1] = xr + fv[numpar + 1] = fxr + how = "reflect" + } else { + if(fxr < fv[numpar + 1]) + { + ## Calculate outside contraction point + xco = (1 + ps * rh) * xbar - ps * rh * v[,numpar + 1] + fxco = -fun(trparsopt = xco, ...) + if(fxco <= fxr) + { + v[,numpar + 1] = xco + fv[numpar + 1] = fxco + how = "contract outside" + } else { + how = "shrink" + } + } else { + ## Calculate inside contraction point + xci = (1 - ps) * xbar + ps * v[,numpar + 1] + fxci = -fun(trparsopt = xci, ...) + if(fxci < fv[numpar + 1]) + { + v[,numpar + 1] = xci + fv[numpar + 1] = fxci + how = "contract inside" + } else { + how = "shrink" + } + } + if(how == "shrink") + { + for(j in 2:(numpar + 1)) + { + + v[,j] = v[,1] + si * (v[,j] - v[,1]) + fv[j] = -fun(trparsopt = v[,j], ...) + } + } + } + } + tmp = order(fv) + if(numpar == 1) + { + v = matrix(v[tmp],nrow = 1,ncol = 2) + } else { + v = v[,tmp] + } + fv = fv[tmp] + itercount = itercount + 1 + string = itercount; + for(i in 1:numpar) + { + string = paste(string, untransform_pars(v[i,1]), sep = " ") + } + string = paste(string, -fv[1], how, "\n", sep = " ") + cat(string) + utils::flush.console() + v2 = t(matrix(rep(v[,1],each = numpar + 1),nrow = numpar + 1)) } if(itercount < maxiter) { - cat("Optimization has terminated successfully.","\n") + cat("Optimization has terminated successfully.","\n") } else { - cat("Maximum number of iterations has been exceeded.","\n") + cat("Maximum number of iterations has been exceeded.","\n") } out = list(par = v[,1], fvalues = -fv[1], conv = as.numeric(itercount > maxiter)) invisible(out) @@ -780,7 +780,7 @@ optimizer <- function( itermax = optimpars[4], packages = c('DDD')), fun = fun, - + ...))$optim outnew <- list(par = outnew$bestmem, fvalues = -outnew$bestval, conv = 0) } @@ -951,3 +951,62 @@ get_Kprime <- function(ddmodel, pars) { return(Kprime) } +#' Helper function to quickly find what a ddmodel contains +#' +#' Given a ddmodel code, returns a short description of the contents of the model +#' +#' @param ddmodel a integer code between 1 and 15, corresponding to one of the +#' diversity-dependent models taken as input e.g. in [dd_ML()] and [dd_loglik()]. +#' @param short logical. If FALSE (the default), returns a description of the +#' diversity-dependent functions used for speciation and extinction. If TRUE, +#' instead returns a 2-letter code (speciation + extinction) summarising these +#' functions: L for liner DD, P for a power DD function, X for an exponential DD +#' function, and C for a constant rate (no DD). +#' +#' @export +#' @author Theo Pannetier +what_is_this_ddmodel <- function(ddmodel, short = FALSE) { + if (!ddmodel %in% 1:15) { + stop("ddmodel not found") + } + if (!short) { + switch( + as.character(ddmodel), + "1" = "linear DD on speciation, constant-rate extinction", + "2" = "exponential (power function) DD on speciation, constant-rate extinction", + "3" = "constant-rate speciation, linear DD on extinction", + "4" = "constant-rate speciation, exponential (power function) DD on extinction", + "5" = "linear DD on speciation, linear DD on extinction", + "6" = "linear DD on speciation, exponential DD (power function) on extinction", + "7" = "exponential (power function) DD on speciation, exponential (power function) DD on extinction", + "8" = "exponential (power function) DD on speciation, linear DD on extinction", + "9" = "exponential (exponential function) DD on speciation, constant-rate extinction", + "10" = "constant-rate speciation, exponential (exponential function) DD on extinction", + "11" = "linear DD on speciation, exponential (exponential function) DD on extinction", + "12" = "exponential (exponential function) DD on speciation, exponential (exponential function) DD on extinction", + "13" = "exponential (exponential function) DD on speciation, linear DD on speciation", + "14" = "exponential (exponential function) DD on speciation, exponential (power function) DD on extinction", + "15" = "exponential (power function) DD on speciation, exponential (exponential function) DD on extinction" + ) + } else { + switch ( + as.character(ddmodel), + "1" = "LC", + "2" = "PC", + "3" = "CL", + "4" = "CP", + "5" = "LL", + "6" = "LP", + "7" = "PP", + "8" = "PL", + "9" = "XC", + "10" = "CX", + "11" = "LX", + "12" = "XX", + "13" = "XL", + "14" = "XP", + "15" = "PX" + ) + } +} + diff --git a/man/dd_KI_loglik.Rd b/man/dd_KI_loglik.Rd index ab9f9a6..f2ca0cc 100644 --- a/man/dd_KI_loglik.Rd +++ b/man/dd_KI_loglik.Rd @@ -100,11 +100,11 @@ shift in parameters. } \examples{ -pars1 = c(0.25,0.12,25.51,1.0,0.16,8.61,9.8) -pars2 = c(200,1,0,18.8,1,2) -missnumspec = 0 -brtsM = c(25.2,24.6,24.0,22.5,21.7,20.4,19.9,19.7,18.8,17.1,15.8,11.8,9.7,8.9,5.7,5.2) -brtsS = c(9.6,8.6,7.4,4.9,2.5) +pars1 <- c(0.25,0.12,25.51,1.0,0.16,8.61,9.8) +pars2 <- c(200,1,0,18.8,1,2) +missnumspec <- 0 +brtsM <- c(25.2,24.6,24.0,22.5,21.7,20.4,19.9,19.7,18.8,17.1,15.8,11.8,9.7,8.9,5.7,5.2) +brtsS <- c(9.6,8.6,7.4,4.9,2.5) dd_KI_loglik(pars1,pars2,brtsM,brtsS,missnumspec) } diff --git a/man/dd_SR_ML.Rd b/man/dd_SR_ML.Rd index b697299..d009c40 100644 --- a/man/dd_SR_ML.Rd +++ b/man/dd_SR_ML.Rd @@ -7,8 +7,8 @@ diversification model with a shift in the parameters} \usage{ dd_SR_ML( brts, - initparsopt = c(0.5, 0.1, 2 * (1 + length(brts) + missnumspec), 2 * (1 + length(brts) - + missnumspec), max(brts)/2), + initparsopt = c(0.5, 0.1, 2 * (1 + length(brts) + missnumspec), 2 * (1 + length(brts) + + missnumspec), max(brts)/2), parsfix = NULL, idparsopt = c(1:3, 6:7), idparsfix = NULL, diff --git a/man/dd_loglik.Rd b/man/dd_loglik.Rd index 5b8e5a8..9945c17 100644 --- a/man/dd_loglik.Rd +++ b/man/dd_loglik.Rd @@ -59,6 +59,11 @@ dependence (exponential function) in extinction\cr speciation and extinction\cr \cr - \code{pars2[2] == 13} exponential dependence (exponential function) in speciation, linear dependence in extinction \cr +\cr - \code{pars2[2] == 14} exponential dependence (exponential function) in +speciation, exponential dependence (power function) in extinction \cr +\cr - \code{pars2[2] == 15} exponential dependence (power function) in +speciation, exponential dependence (exponential function) in extinction \cr + \cr \cr \code{pars2[3]} sets the conditioning: \cr - \code{pars2[3] == 0} conditioning on stem or crown age \cr - \code{pars2[3] == 1} conditioning on stem or crown age and diff --git a/man/dd_multiple_KI_loglik.Rd b/man/dd_multiple_KI_loglik.Rd index 1d0a8ea..8d8b983 100644 --- a/man/dd_multiple_KI_loglik.Rd +++ b/man/dd_multiple_KI_loglik.Rd @@ -16,7 +16,7 @@ dd_multiple_KI_loglik( ) } \arguments{ -\item{pars1_list}{list of paramater sets one for each rate regime (subclade). +\item{pars1_list}{list of parameter sets one for each rate regime (subclade). The parameters are: lambda (speciation rate), mu (extinction rate), and K (clade-level carrying capacity).} diff --git a/man/what_is_this_ddmodel.Rd b/man/what_is_this_ddmodel.Rd new file mode 100644 index 0000000..55b8e1f --- /dev/null +++ b/man/what_is_this_ddmodel.Rd @@ -0,0 +1,24 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/dd_utils.R +\name{what_is_this_ddmodel} +\alias{what_is_this_ddmodel} +\title{Helper function to quickly find what a ddmodel contains} +\usage{ +what_is_this_ddmodel(ddmodel, short = FALSE) +} +\arguments{ +\item{ddmodel}{a integer code between 1 and 15, corresponding to one of the +diversity-dependent models taken as input e.g. in [dd_ML()] and [dd_loglik()].} + +\item{short}{logical. If FALSE (the default), returns a description of the +diversity-dependent functions used for speciation and extinction. If TRUE, +instead returns a 2-letter code (speciation + extinction) summarising these +functions: L for liner DD, P for a power DD function, X for an exponential DD +function, and C for a constant rate (no DD).} +} +\description{ +Given a ddmodel code, returns a short description of the contents of the model +} +\author{ +Theo Pannetier +}