fCopulae/0000755000176000001440000000000012406311445012040 5ustar ripleyusersfCopulae/inst/0000755000176000001440000000000012406047540013017 5ustar ripleyusersfCopulae/inst/unitTests/0000755000176000001440000000000012406047540015021 5ustar ripleyusersfCopulae/inst/unitTests/runit.ArchimedeanModelling.R0000644000176000001440000000453512406047540022346 0ustar ripleyusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA # Copyrights (C) # for this R-port: # 1999 - 2007, Diethelm Wuertz, GPL # Diethelm Wuertz # info@rmetrics.org # www.rmetrics.org # for the code accessed (or partly included) from other R-ports: # see R's copyright and license files # for the code accessed (or partly included) from contributed R-ports # and other sources # see Rmetrics's copyright file ################################################################################ # FUNCTION: ARCHIMEDEAN COPULAE PARAMETER FITTING: # archmCopulaSim Simulates bivariate elliptical copula # archmCopulaFit Fits the paramter of an elliptical copula ################################################################################ test.archmCopulaSim = function() { # Arguments: # archmCopulaSim(n, alpha = NULL, type = archmList()) # Simulate Random Variates: for (type in archmList()) { ans = archmCopulaSim(5, type = type) cat("\n") print(type) print(ans) } # Return Value: return() } # ------------------------------------------------------------------------------ test.archmCopulaFit = function() { # Arguments: # archmCopulaFit(u, v = NULL, type = archmList(), ...) # Random Variates: R = archmCopulaSim(n = 100, alpha = 2, type = "4") # Fit: fit = archmCopulaFit(u = R, type = "4") fit # Fit: fit = archmCopulaFit(u = R[, 1], v = R[, 2], type = "4") fit # Return Value: return() } ################################################################################ fCopulae/inst/unitTests/Makefile0000644000176000001440000000042012406047540016455 0ustar ripleyusersPKG=fCopulae TOP=../.. SUITE=doRUnit.R R=R all: inst test inst: # Install package -- but where ?? -- will that be in R_LIBS ? cd ${TOP}/..;\ ${R} CMD INSTALL ${PKG} test: # Run unit tests export RCMDCHECK=FALSE;\ cd ${TOP}/tests;\ ${R} --vanilla --slave < ${SUITE}fCopulae/inst/unitTests/runit.ExtremeValueCopulae.R0000644000176000001440000001105112406047540022221 0ustar ripleyusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA # Copyrights (C) # for this R-port: # 1999 - 2007, Diethelm Wuertz, GPL # Diethelm Wuertz # info@rmetrics.org # www.rmetrics.org # for the code accessed (or partly included) from other R-ports: # see R's copyright and license files # for the code accessed (or partly included) from contributed R-ports # and other sources # see Rmetrics's copyright file ################################################################################ # FUNCTION: EXTREME VALUE COPULAE RANDOM VARIATES: # revCopula Generates extreme value copula random variates # revSlider isplays interactively plots of random variates # FUNCTION: EXTREME VALUE COPULAE PROBABILIY: # pevCopula Computes extreme value copula probability # pevSlider Displays interactively plots of probability # FUNCTION: EXTREME VALUE COPULAE DENSITY: # devCopula Computes extreme value copula density # devSlider Displays interactively plots of density ################################################################################ test.revCopula = function() { # Arguments: # revCopula(n, param = NULL, type = evList()) # Random Variates - Check all Types: for (type in evList()) { R = revCopula(n = 5, param = NULL, type = type) cat("\n") print(type) print(R) } # Tawn Copula: revCopula(n = 5, param = NULL, type = "tawn") # Return Value: return() } # ------------------------------------------------------------------------------ test.revSlider = function() { # Arguments: # revSlider(B = 10) # Try Slider() # revSlider() # CHECK !!! NA # Return Value: return() } ################################################################################ test.pevCopula = function() { # Arguments: # pevCopula(u = 0.5, v = u, param = NULL, type = evList(), # output = c("vector", "list"), alternative = FALSE) # Random Variates - Check all Types: for (type in evList()) { R = pevCopula(u = grid2d(), param = NULL, type = type, output = "list") cat("\n") print(type) print(R) } # Tawn Copula: revCopula(n = 5, param = NULL, type = "tawn") # Return Value: return() } # ------------------------------------------------------------------------------ test.pevSlider = function() { # Arguments: # pevSlider(type = c("persp", "contour"), B = 10) # Try Perspective Slider: # pevSlider("persp") NA # Try Contour Slider: # pevSlider("contour") NA # Return Value: return() } ################################################################################ test.devCopula = function() { # Arguments: # devCopula(u = 0.5, v = u, param = NULL, type = evList(), # output = c("vector", "list"), alternative = FALSE) # Random Variates - Check all Types: for (type in evList()) { R = devCopula(u = grid2d(), param = NULL, type = type, output = "list") cat("\n") print(type) print(R) } # CHECK Border !!!! # Tawn Copula: revCopula(n = 5, param = NULL, type = "tawn") # Return Value: return() } # ------------------------------------------------------------------------------ test.devSlider = function() { # Arguments: # devSlider(type = c("persp", "contour"), B = 10) # Try Perspective Slider: # devSlider("persp") NA # Try Contour Slider: # devSlider("contour") NA # Return Value: return() } ################################################################################ fCopulae/inst/unitTests/runit.ExtrmeValueGenerator.R0000644000176000001440000000721412406047540022420 0ustar ripleyusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA # Copyrights (C) # for this R-port: # 1999 - 2007, Diethelm Wuertz, GPL # Diethelm Wuertz # info@rmetrics.org # www.rmetrics.org # for the code accessed (or partly included) from other R-ports: # see R's copyright and license files # for the code accessed (or partly included) from contributed R-ports # and other sources # see Rmetrics's copyright file ################################################################################ # FUNCTION: EXTREME VALUE COPULAE PARAMETER: # evList Returns list of implemented extreme value copulae # evParam Sets Default parameters for an extreme value copula # evRange Returns the range of valid parameter values # evCheck Checks if parameters are in the valid range # FUNCTION: EXTREME VALUE COPULAE GENERATOR FUNCTION: # Afunc Computes Dependence function # AfuncSlider Displays interactively dependence function ################################################################################# test.evList = function() { # Arguments: # evList() # List: evList() # c("gumbel", "galambos", "husler.reiss", "tawn", "bb5") # Return Value: return() } # ------------------------------------------------------------------------------ test.evParam = function() { # Arguments: # evParam(type = evList()) # Parameters: for (type in evList()) { cat("\n") print(unlist(evParam(type))) } # Return Value: return() } # ------------------------------------------------------------------------------ test.evRange = function() { # Arguments: # evRange(type = evList()) # Range: for (type in evList()) { cat("\n") print(evRange(type)) } # Return Value: return() } # ------------------------------------------------------------------------------ test.evCheck = function() { # Arguments: # evCheck(type = evList()) # Check: for (type in evList()) { cat("\n") param = evParam(type)$param print(evCheck(param)) } # Return Value: return() } ################################################################################ test.Afunc = function() { # Arguments: # Afunc(x, param = NULL, type = evList() # Afunc: x = (0:10)/10 for (type in evList()) { cat("\n") print(type) print(Afunc(x, type = type)) } # Return Value: return() } # ------------------------------------------------------------------------------ test.AfuncSlider = function() { # Arguments: # AfuncSlider() # Try Slider: # AfuncSlider() NA # Return Value: return() } ################################################################################ fCopulae/inst/unitTests/runit.EmpiricalCopulae.R0000644000176000001440000000360612406047540021527 0ustar ripleyusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA # Copyrights (C) # for this R-port: # 1999 - 2007, Diethelm Wuertz, GPL # Diethelm Wuertz # info@rmetrics.org # www.rmetrics.org # for the code accessed (or partly included) from other R-ports: # see R's copyright and license files # for the code accessed (or partly included) from contributed R-ports # and other sources # see Rmetrics's copyright file ################################################################################ # FUNCTION: EMPIRICAL COPULAE: # pempiricalCopula Computes empirical copula probability # dempiricalCopula Computes empirical copula density ################################################################################ test.pempiricalCopula = function() { # Arguments: # pempiricalCopula(u, v, N = 10) NA # Return Value: return() } # ------------------------------------------------------------------------------ test.dempiricalCopula = function() { # Arguments: # dempiricalCopula(u, v, N = 10) NA # Return Value: return() } ################################################################################ fCopulae/inst/unitTests/runit.EllipticalCopulae.R0000644000176000001440000001120712406047540021700 0ustar ripleyusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA ################################################################################ # FUNCTION: ELLIPTICAL COPULAE RANDOM DEVIATES: # rellipticalCopula Generates elliptical copula variates # rellipticalSlider Interactive plots of random variates # FUNCTION: ELLIPTICAL COPULAE PROBABILITY: # pellipticalCopula Computes elliptical copula probability # pellipticalSlider Interactive plots of probability # FUNCTION: ELLIPTICAL COPULAE DENSITY: # dellipticalCopula Computes elliptical copula density # dellipticalSlider Interactive plots of density ################################################################################ test.rellipticalCopula = function() { # Random Number Generator: R <- rellipticalCopula(1000, type = "norm") plot(R, pch = 19, col = "steelblue", main = "norm") grid() R <- rellipticalCopula(1000, type = "cauchy") plot(R, pch = 19, col = "steelblue", main = "cauchy") grid() R <- rellipticalCopula(1000, type = "t") plot(R, pch = 19, col = "steelblue", main = "t-default") grid() R <- rellipticalCopula(1000, param = c(nu = 3), type = "t") plot(R, pch = 19, col = "steelblue", main = "t3") grid() R <- rellipticalCopula(1000, param = 3, type = "t") plot(R, pch = 19, col = "steelblue", main = "t3") grid() # The remaining copulae are not yet implemented ... # Return Value: return() } # ------------------------------------------------------------------------------ test.rellipticalSlider <- function() { # Try Slider: # rellipticalSlider() NA # Return Value: return() } ################################################################################ test.pellipticalCopula <- function() { # Arguments ? # pellipticalCopula(u = 0.5, v = u, rho = 0.75, param = NULL, # type = ellipticalList(), output = c("vector", "list"), border = TRUE) # Use Default Settings: par (mfrow = c(1, 1)) for (type in ellipticalList()) { UV <- grid2d() p <- pellipticalCopula(u = UV, rho = 0.75, type = type, output = "list") print(type) persp(p, main = type, theta = -40, phi = 30, col = "steelblue", ps = 9, xlab = "u", ylab = "v", zlab = "C") } # Return Value: return() } # ------------------------------------------------------------------------------ test.pellipticalSlider = function() { # Arguments: # pellipticalSlider(type = c("persp", "contour"), B = 20) # Try Perspective Slider: # pellipticalSlider() NA # Try Contour Slider: # pellipticalSlider("contour") NA # Return Value: return() } ################################################################################ test.dellipticalCopula = function() { # Arguments ? # dellipticalCopula(u = 0.5, v = u, rho = 0.75, param = NULL, # type = ellipticalList(), output = c("vector", "list"), border = TRUE) # Use Default Settings: par (mfrow = c(1, 1)) for (type in ellipticalList()) { UV = grid2d() d = dellipticalCopula(u = UV, rho = 0.75, type = type, output = "list") print(type) persp(d, main = type, theta = -40, phi = 30, col = "steelblue", ps = 9, xlab = "u", ylab = "v", zlab = "c") } # Return Value: return() } # ------------------------------------------------------------------------------ test.dellipticalSlider = function() { # Arguments: # dellipticalSlider(type = c("persp", "contour"), B = 20) # Try Perspective Slider: # dellipticalSlider() NA # Try Contour Slider: # dellipticalSlider("contour") NA # Return Value: return() } ################################################################################ fCopulae/inst/unitTests/runit.ArchimedeanDependency.R0000644000176000001440000000711312406047540022505 0ustar ripleyusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA # Copyrights (C) # for this R-port: # 1999 - 2007, Diethelm Wuertz, GPL # Diethelm Wuertz # info@rmetrics.org # www.rmetrics.org # for the code accessed (or partly included) from other R-ports: # see R's copyright and license files # for the code accessed (or partly included) from contributed R-ports # and other sources # see Rmetrics's copyright file ################################################################################ # FUNCTION KENDALL'S TAU AND SPEARMAN'S RHO: # archmTau Returns Kendall's tau for Archemedean copulae # archmRho Returns Spearman's rho for Archemedean copulae # FUNCTION: ARCHIMEDEAN COPULAE TAIL COEFFICIENT: # archmTailCoeff Computes tail dependence for Archimedean copulae # archmTailPlot Plots Archimedean tail dependence function ################################################################################ test.archmTau = function() { # Arguments: # archmTau(alpha = NULL, type = archmList(), lower = 1e-10) # Tau: for (type in archmList()) { ans = archmTau(type = type) cat("\n") print(type) print(ans) } # Return Value: return() } # ------------------------------------------------------------------------------ test.archmRho = function() { # Arguments: # archmRho(alpha = NULL, type = archmList(), # method = c("integrate2d", "adapt"), error = 1e-05) # Rho: for (type in archmList()) { ans = archmRho(alpha = NULL, type = type, method = "integrate2d", error = 1e-5) cat("\n") print(type) print(ans) } # Return Value: return() } ################################################################################ test.archmTailCoeff = function() { # Arguments: # archmTailCoeff(alpha = NULL, type = archmList()) # Tail Coefficient: for (type in archmList()) { ans = archmTailCoeff(alpha = NULL, type = type) cat("\n") print(type) print(ans) } # Return Value: return() } # ------------------------------------------------------------------------------ test.archmTailPlot = function() { # Arguments: # archmTailPlot(alpha = NULL, type = archmList(), # tail = c("Upper", "Lower")) # Lower Tail Coefficient Plot: par(mfrow = c(2, 2), cex = 0.7) for (type in archmList()) { print(type) archmTailPlot(alpha = NULL, type = type, tail = "Upper") } # Upper Tail Coefficient Plot: for (type in archmList()) { print(type) archmTailPlot(alpha = NULL, type = type, tail = "Lower") } # Return Value: return() } ################################################################################ fCopulae/inst/unitTests/runit.EllipticalModelling.R0000644000176000001440000001021212406047540022215 0ustar ripleyusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA # Copyrights (C) # for this R-port: # 1999 - 2007, Diethelm Wuertz, GPL # Diethelm Wuertz # info@rmetrics.org # www.rmetrics.org # for the code accessed (or partly included) from other R-ports: # see R's copyright and license files # for the code accessed (or partly included) from contributed R-ports # and other sources # see Rmetrics's copyright file ################################################################################ # FUNCTION: ELLIPTICAL COPULAE PARAMETER FITTING: # ellipticalCopulaSim Simulates bivariate elliptical copula # ellipticalCopulaFit Fits the paramter of an elliptical copula ################################################################################ test.copulaSim = function() { # Arguments: # ellipticalCopulaSim(n, rho = 0.75, param = NULL, # type = c("norm", "cauchy", "t")) # Normal Copula: rho = 0.5 R = ellipticalCopulaSim(n = 1000, rho = rho) R[1:10, ] plot(R, pch = 19) # Cauchy Copula: rho = runif(1, -1, 1) R = ellipticalCopulaSim(n = 100, rho = rho, type = "cauchy") R[1:10, ] plot(R, pch = 19) # Student-t Copula: rho = runif(1, -1, 1) nu = runif(1, 3, 20) print(c(rho, nu)) R = ellipticalCopulaSim(n = 1000, rho = rho, param = nu, type = "t") R[1:10, ] plot(R, pch = 19) # The remaining Copulae are not yet implemented ... # Return Value: return() } # ------------------------------------------------------------------------------ test.copulaFit = function() { # Arguments: # ellipticalCopulaFit(u, v = NULL, type = c("norm", "cauchy", "t"), ...) # Fit Normal Copula: rho = 0.5 R = ellipticalCopulaSim(n = 1000, rho = rho) fit = ellipticalCopulaFit(u = R[,1], v = R[,2]) fit rho - fit$par plot(c(-1,1), c(-1,1), xlab = "rho", ylab = "estimate", main = "Normal") for ( i in 1:100) { rho = runif(1, -1, 1) R = ellipticalCopulaSim(n = 1000, rho = rho) fit = ellipticalCopulaFit(R) points(rho, fit$par) print(c(rho, fit$par)) } # Fit Cauchy Copula: rho = runif(1, -1, 1) R = ellipticalCopulaSim(n = 100, rho = rho, type = "cauchy") ellipticalCopulaFit(R, type = "cauchy") rho plot(c(-1,1), c(-1,1), main = "Cauchy") for ( i in 1:100) { rho = runif(1, -1, 1) R = ellipticalCopulaSim(n = 1000, rho = rho, type = "cauchy") fit = ellipticalCopulaFit(R, type = "cauchy") points(rho, fit$par) print(c(rho, fit$par)) } # Fit Student-t Copula: rho = runif(1, -1, 1) nu = runif(1, 3, 20) print(c(rho, nu)) R = ellipticalCopulaSim(n = 1000, rho = rho, param = nu, type = "t") ellipticalCopulaFit(R, type = "t") plot(c(-1,1), c(-1,1), main = "Student-t") for ( i in 1:100) { rho = runif(1, -1, 1) nu = runif(1, 3, 20) R = ellipticalCopulaSim(n = 1000, rho = rho, param = nu, type = "t") fit = ellipticalCopulaFit(R, type = "t") points(rho, fit$par[1]) print(c(rho, nu, fit$par)) } # The remaining Copulae are not yet implemented ... # Return Value: return() } ################################################################################ fCopulae/inst/unitTests/runit.EllipticalDependency.R0000644000176000001440000000637412406047540022377 0ustar ripleyusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA # Copyrights (C) # for this R-port: # 1999 - 2007, Diethelm Wuertz, GPL # Diethelm Wuertz # info@rmetrics.org # www.rmetrics.org # for the code accessed (or partly included) from other R-ports: # see R's copyright and license files # for the code accessed (or partly included) from contributed R-ports # and other sources # see Rmetrics's copyright file ################################################################################ # FUNCTION: ELLIPTICAL COPULAE DEPENDENCE MASURES: # ellipticalTau Computes Kendall's tau for elliptical copulae # ellipticalRho Computes Spearman's rho for elliptical copulae # FUNCTION: ELLIPTICAL COPULAE TAIL COEFFICIENT: # ellipticalTailCoeff Computes tail dependence for elliptical copulae # ellipticalTailPlot Plots tail dependence function ################################################################################ test.ellipticalTau = function() { # Computes Kendall's tau for elliptical copulae args(ellipticalTau) ellipticalTau(rho = 0.5) ellipticalTau(rho = c(-0.5, 0, 0.5)) # Return Value: return() } # ------------------------------------------------------------------------------ test.ellipticalRho = function() { # Computes Spearman's rho for elliptical copulae args(ellipticalRho) ellipticalRho(0.5) ellipticalRho(rho = c(-0.5, 0, 0.5)) # Return Value: return() } ################################################################################ test.ellipticalTailCoeff = function() { # Lower - Upper ---- # Tail Coefficient - Using Default Parameters: Type = c("norm", "cauchy", "t") for (type in Type) { ans = ellipticalTailCoeff(rho = 0.5, type = type) print(ans) cat("\n") } # Return Value: return() } # ------------------------------------------------------------------------------ test.ellipticalTailPlot = function() { # Arguments: # ellipticalTailPlot(param = NULL, type = c("norm", "cauchy", "t"), # tail = c("Lower", "Upper")) # Plot - Be patient, plotting takes some time ... Type = c("norm", "cauchy", "t") for (type in Type) { par(mfrow = c(2, 2), cex = 0.7) ellipticalTailPlot(type = type) ellipticalTailPlot(type = type, tail = "Lower") } # Return Value: return() } ################################################################################ fCopulae/inst/unitTests/runit.ArchimedeanCopulae.R0000644000176000001440000001535612406047540022027 0ustar ripleyusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA # Copyrights (C) # for this R-port: # 1999 - 2007, Diethelm Wuertz, GPL # Diethelm Wuertz # info@rmetrics.org # www.rmetrics.org # for the code accessed (or partly included) from other R-ports: # see R's copyright and license files # for the code accessed (or partly included) from contributed R-ports # and other sources # see Rmetrics's copyright file ################################################################################ # FUNCTION: ARCHIMEDEAN COPULAE RANDOM VARIATES: # rarchmCopula Generates Archimedean copula random variates # rarchmSlider Displays interactively archimedean probability # FUNCTION: ARCHIMEDEAN COPULAE PROBABILITY: # parchmCopula Computes Archimedean copula probability # parchmSlider Displays interactively archimedean probability # FUNCTION: ARCHIMEDEAN COPULAE DENSITY: # darchmCopula Computes Archimedean copula density # darchmSlider Displays interactively archimedean density # FUNCTION: SPECIAL BIVARIATE COPULA: # rgumbelCopula Generates fast gumbel random variates # pgumbelCopula Computes bivariate Gumbel copula probability # dgumbelCopula Computes bivariate Gumbel copula density ################################################################################ test.rarchmCopula = function() { # Arguments: # rarchmCopula(n, alpha = NULL, type = archmList()) # Random Variates - Check all Types: for (type in archmList()) { R = rarchmCopula(n = 5, alpha = NULL, type = type) cat("\n") print(type) print(R) } # Return Value: return() } # ------------------------------------------------------------------------------ test.rarchmSlider = function() { # Arguments: # rarchmSlider(B = 10) # Try Slider: # rarchmSlider() NA # Return Value: return() } ################################################################################ test.parchmCopula = function() { # Arguments: # parchmCopula(u = 0.5, v = u, alpha = NULL, type = archmList(), # output = c("vector", "list"), alternative = FALSE) # u - single input value: parchmCopula() parchmCopula(0.5) parchmCopula(0.5, 0.25) # u - input vector: U = (0:10)/10 V = U parchmCopula(U) parchmCopula(u = U, v = V) parchmCopula(u = U, v = rev(V)) # u - input matrix: parchmCopula(cbind(U, V)) # u - input list: u = grid2d() u parchmCopula(u) # output = "vector" parchmCopula(u, output = "list") diff = parchmCopula(u) - parchmCopula(u, alternative = TRUE) mean(abs(diff)) # Check All Types: u = grid2d() for (type in paste(1:22)) { cop1 = parchmCopula(u, type = type, output = "list") cop2 = parchmCopula(u, type = type, output = "list", alternative = TRUE) cat("Type: ", type, "\t Difference: ", mean(abs(cop1$z-cop2$z)), "\n") persp(cop1, main = type, theta = -40, phi = 30, col = "steelblue") } # Return Value: return() } # ------------------------------------------------------------------------------ test.parchmSlider = function() { # Arguments: # parchmSlider(type = c("persp", "contour"), B = 10) # Try Perspective Slider: # parchmSlider() NA # Try Contour Slider: # parchmSlider("contour") NA # Return Value: return() } ################################################################################ test.darchmCopula = function() { # Arguments: # darchmCopula(u = 0.5, v = u, alpha = NULL, type = archmList(), # output = c("vector", "list"), alternative = FALSE) # u - single input value: darchmCopula() darchmCopula(0.5) darchmCopula(0.5, 0.25) # u - input vector: U = (0:10)/10 V = U darchmCopula(U) darchmCopula(u = U, v = V) darchmCopula(u = U, v = rev(V)) # u - input matrix: darchmCopula(cbind(U, V)) # u - input list: u = grid2d() u darchmCopula(u) # output = "vector" darchmCopula(u, output = "list") # Check All Types: u = grid2d(x = (0:25)/25) for (type in archmList()) { cop1 = darchmCopula(u, type = type, output = "list") cop2 = darchmCopula(u, type = type, output = "list", alternative = TRUE) diff = abs(cop1$z-cop2$z) diff = diff[!is.na(diff)] cat("Type: ", type, "\t Difference: ", mean(diff), "\n") persp(cop2, main = type, theta = -40, phi = 30, col = "steelblue") } # Return Value: return() } # ------------------------------------------------------------------------------ test.darchmSlider = function() { # Arguments: # darchmSlider(type = c("persp", "contour"), B = 10) # Try Perspective Slider: # darchmSlider() NA # Try Contour Slider: # darchmSlider("contour") NA # Return Value: return() } ################################################################################ test.rgumbelCopula = function() { # Generates fast gumbel random variates # Copula: rgumbelCopula() # Return Value: return() } # ------------------------------------------------------------------------------ test.pgumbelCopula = function() { # Computes bivariate Gumbel copula probability # Copula: pgumbelCopula() # Return Value: return() } # ------------------------------------------------------------------------------ test.dgumbelCopula = function() { # Computes bivariate Gumbel copula density # Copula: dgumbelCopula() # Return Value: return() } ################################################################################ fCopulae/inst/unitTests/runit.aaaCopulaClass.R0000644000176000001440000000740212406047540021163 0ustar ripleyusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA # Copyrights (C) # for this R-port: # 1999 - 2007, Diethelm Wuertz, GPL # Diethelm Wuertz # info@rmetrics.org # www.rmetrics.org # for the code accessed (or partly included) from other R-ports: # see R's copyright and license files # for the code accessed (or partly included) from contributed R-ports # and other sources # see Rmetrics's copyright file ################################################################################ # FUNCTION: SPECIFICATION: # fCOPULA S4 class representation # show S4 print method for copula specification # FUNCTION: FRECHET COPULAE: # pfrechetCopula Computes Frechet copula probability # FUNCTION: SPEARMAN'S RHO: # .copulaRho Spearman's rho by integration for "ANY" copula ################################################################################ test.pfrechetCopula = function() { # pfrechetCopula(u = 0.5, v = u, type = c("m", "pi", "w"), # output = c("vector", "list")) # Grid: grid2d() grid2d(x = (0:10)/10) # Vector - M Copula: copula.vector = pfrechetCopula(u = grid2d(), output = "vector", type = "m") copula.vector class(copula.vector) cbind(u = grid2d()$x, v = grid2d()$y, C = copula.vector) # List - M Copula: copula.list = pfrechetCopula(u = grid2d(), output = "list", type = "m") copula.list class(copula.list) persp(copula.list, theta = -40, phi = 30, col = "steelblue", ps = 9) # Vector - Pi Copula: copula.vector = pfrechetCopula(u = grid2d(), output = "vector", type = "pi") copula.vector class(copula.vector) cbind(u = grid2d()$x, v = grid2d()$y, C = copula.vector) # List - Pi Copula: copula.list = pfrechetCopula(u = grid2d(), output = "list", type = "pi") copula.list class(copula.list) persp(copula.list, theta = -40, phi = 30, col = "steelblue", ps = 9) # Vector - W Copula: copula.vector = pfrechetCopula(u = grid2d(), output = "vector", type = "w") copula.vector class(copula.vector) cbind(u = grid2d()$x, v = grid2d()$y, C = copula.vector) # List - W Copula: copula.list = pfrechetCopula(u = grid2d(), output = "list", type = "w") copula.list class(copula.list) persp(copula.list, theta = -40, phi = 30, col = "steelblue", ps = 9) # Return Value: return() } ################################################################################ test.copulaRho = function() { # .copulaRho(rho = NULL, alpha = NULL, param = NULL, # family = c("elliptical", "archm", "ev", "archmax"), # type = NULL, error = 1e-3, ...) # Elliptical: fCopulae:::.copulaRho(rho = 0.5, family = "elliptical", type = "norm") # Return Value: return() } ################################################################################ fCopulae/inst/unitTests/runit.ExtremeValueModelling.R0000644000176000001440000000470412406047540022552 0ustar ripleyusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA # Copyrights (C) # for this R-port: # 1999 - 2007, Diethelm Wuertz, GPL # Diethelm Wuertz # info@rmetrics.org # www.rmetrics.org # for the code accessed (or partly included) from other R-ports: # see R's copyright and license files # for the code accessed (or partly included) from contributed R-ports # and other sources # see Rmetrics's copyright file ################################################################################ # FUNCTION: EXTREME VALUE COPULA PARAMETER FITTING: # evCopulaSim Simulates bivariate extreme value copula # evCopulaFit Fits the paramter of an extreme value copula ################################################################################# test.evCopulaSim = function() { # Arguments: # evCopulaSim(n, param = NULL, type = evList()) # Simulate Random Variates: for (type in evList()) { ans = evCopulaSim(5, type = type) cat("\n") print(type) print(ans) } # Return Value: return() } # ------------------------------------------------------------------------------ test.evCopulaFit = function() { # Arguments: # evCopulaFit(u, v = NULL, type = evList(), ...) # Random Variates: set.seed(4711) type = "gumbel" R = evCopulaSim(500, param = NULL, type = type) Index = which(is.na(R[,2])) R = R[-Index, ] # Fit: ### evCopulaFit(u = R, type = type) # Check # Fit: ### evCopulaFit(u = R[, 1], v = R[, 2], type = type) # Check # Return Value: return() } ################################################################################ fCopulae/inst/unitTests/runit.EllipticalGenerator.R0000644000176000001440000001730112406047540022237 0ustar ripleyusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA # Copyrights (C) # for this R-port: # 1999 - 2007, Diethelm Wuertz, GPL # Diethelm Wuertz # info@rmetrics.org # www.rmetrics.org # for the code accessed (or partly included) from other R-ports: # see R's copyright and license files # for the code accessed (or partly included) from contributed R-ports # and other sources # see Rmetrics's copyright file ################################################################################ # FUNCTION: UTILITY FUNCTIONS: # ellipticalList Returns list of implemented Elliptical copulae # ellipticalParam Sets default parameters for an elliptical copula # ellipticalRange Returns the range of valid rho values # ellipticalCheck Checks if rho is in the valid range # FUNCTION: ELLIPTICAL GENERATOR AND RELATED FUNCTIONS: # gfunc Generator function for elliptical distributions # gfuncSlider Slider for generator, density and probability # .pelliptical Univariate elliptical distribution probability # .delliptical Univariate elliptical distribution density # .qelliptical Univariate elliptical distribution quantiles ################################################################################ test.ellipticalList = function() { # Arguments ? args(ellipticalList) # List: target = c("norm", "cauchy", "t", "logistic", "laplace", "kotz", "epower") current = ellipticalList() print(current) # Return Value: return() } # ------------------------------------------------------------------------------ test.ellipticalRange = function() { # Arguments ? args(ellipticalRange) # Range: for (type in ellipticalList()) { cat("\n") print(ellipticalRange(type)) } # Return Value: return() } # ------------------------------------------------------------------------------ test.ellipticalParam = function() { # Arguments ? args(ellipticalParam) # Parameters: for (type in ellipticalList()) { cat("\n") print(unlist(ellipticalParam(type))) } # Return Value: return() } # ------------------------------------------------------------------------------ test.ellipticalCheck = function() { # Arguments ? args(ellipticalCheck) # ellipticalCheck(rho = 0.75, param = NULL, type = ellipticalList()) # Range: for (type in ellipticalList()) { cat("\n") param = ellipticalParam(type)$param rho = param[1] # Returns NULL if OK print(ellipticalCheck(rho, param[-1], type)) } # Return Value: return() } ################################################################################ test.gfunc = function() { # Arguments ? args(gfunc) # gfunc(x, param = NULL, type = ellipticalList()) # Call Generator Function - Missing x: gfunc(type = "norm") gfunc(type = "cauchy") gfunc(type = "t") gfunc(type = "t", param = 2) gfunc(type = "logistic") gfunc(type = "laplace") gfunc(type = "kotz") gfunc(type = "kotz", param = 2) gfunc(type = "epower") gfunc(type = "epower", param = c(2, 1)) # Call Generator Function - With specified x: gfunc(x = 0:10, type = "norm") gfunc(x = 0:10, type = "cauchy") gfunc(x = 0:10, type = "t") gfunc(x = 0:10, type = "logistic") gfunc(x = 0:10, type = "laplace") gfunc(x = 0:10, type = "kotz") gfunc(x = 0:10, type = "epower") # Return Value: return() } # ------------------------------------------------------------------------------ test.gfuncSlider = function() { # Try Slider: # gfuncSlider() NA # Return Value: return() } # ------------------------------------------------------------------------------ test.pelliptical = function() { # Probability: q = (-1000:1000)/2000 S = NULL s = Sys.time() fCopulae:::.pelliptical(q = q, param = NULL, type = "norm") S = c(S, as.integer(Sys.time() - s)) s = Sys.time() fCopulae:::.pelliptical(q = q, param = NULL, type = "cauchy") S = c(S, as.integer(Sys.time() - s)) s = Sys.time() fCopulae:::.pelliptical(q = q, param = 2, type = "t") S = c(S, as.integer(Sys.time() - s)) s = Sys.time() fCopulae:::.pelliptical(q = q, param = NULL, type = "logistic") S = c(S, as.integer(Sys.time() - s)) s = Sys.time() fCopulae:::.pelliptical(q = q, param = NULL, type = "laplace") S = c(S, as.integer(Sys.time() - s)) s = Sys.time() fCopulae:::.pelliptical(q = q, param = c(r = 1), type = "kotz") S = c(S, as.integer(Sys.time() - s)) s = Sys.time() fCopulae:::.pelliptical(q = q, param = c(r = 1, s = 1), type = "epower") S = c(S, as.integer(Sys.time() - s)) # Return Value: return() } # ------------------------------------------------------------------------------ test.delliptical = function() { # Probability: N = 100 x = (-1999:1999)/N d = fCopulae:::.delliptical(x = x, param = NULL, type = "norm") sum(d)/N d = fCopulae:::.delliptical(x = x, param = NULL, type = "cauchy") sum(d)/N d = fCopulae:::.delliptical(x = x, param = NULL, type = "t") sum(d)/N d = fCopulae:::.delliptical(x = x, param = NULL, type = "logistic") sum(d)/N d = fCopulae:::.delliptical(x = x, param = NULL, type = "laplace") sum(d)/N d = fCopulae:::.delliptical(x = x, param = NULL, type = "kotz") sum(d)/N d = fCopulae:::.delliptical(x = x, param = NULL, type = "epower") sum(d)/N # Non-default Parameters: d = fCopulae:::.delliptical(x = (-100:100)/10, param = 1, type = "kotz") sum(d)/N d = fCopulae:::.delliptical(x = (-100:100)/10, param = 1/2, type = "kotz") sum(d)/N # Return Value: return() } # ------------------------------------------------------------------------------ test.qelliptical = function() { # Probability: p = (0:10)/10 fCopulae:::.qelliptical(p = p, param = NULL, type = "norm") fCopulae:::.qelliptical(p = p, param = NULL, type = "cauchy") fCopulae:::.qelliptical(p = p, param = 2, type = "t") fCopulae:::.qelliptical(p = p, param = NULL, type = "logistic") fCopulae:::.qelliptical(p = p, param = NULL, type = "laplace") fCopulae:::.qelliptical(p = p, param = c(r = 1), type = "kotz") fCopulae:::.qelliptical(p = p, param = c(r = 1, s = 1), type = "epower") # Return Value: return() } ################################################################################ fCopulae/inst/unitTests/runit.ExtremeValueDependency.R0000644000176000001440000000617512406047540022722 0ustar ripleyusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA # Copyrights (C) # for this R-port: # 1999 - 2007, Diethelm Wuertz, GPL # Diethelm Wuertz # info@rmetrics.org # www.rmetrics.org # for the code accessed (or partly included) from other R-ports: # see R's copyright and license files # for the code accessed (or partly included) from contributed R-ports # and other sources # see Rmetrics's copyright file ################################################################################ # FUNCTION KENDALL'S TAU AND SPEARMAN'S RHO: # evTau Returns Kendall's tau for extreme value copulae # evRho Returns Spearman's rho for extreme value copulae # FUNCTION: EXTREME VALUE COPULAE TAIL DEPENDENCE: # evTailCoeff Computes tail dependence for extreme value copulae # evTailCoeffSlider Plots extreme value tail dependence function ################################################################################# test.evTau = function() { # Arguments: # evTau(param = NULL, type = evList(), alternative = FALSE) # Tau: for (type in evList()) { ans = evTau(type = type) cat("\n") print(ans) } # Return Value: return() } # ------------------------------------------------------------------------------ test.evRho = function() { # Arguments: # evRho(param = NULL, type = evList(), alternative = FALSE) # Rho: for (type in evList()) { ans = evRho(type = type) cat("\n") print(type) print(ans) } # Return Value: return() } ################################################################################ test.evTailCoeff = function() { # Arguments: # evTailCoeff(param = NULL, type = evList()) # Tail Coefficient: for (type in evList()) { ans = evTailCoeff(type = type) cat("\n") print(type) print(ans) } # Return Value: return() } # ------------------------------------------------------------------------------ test.evTailCoeffSlider = function() { # Arguments: # evTailCoeffSlider(B = 10) # Try Slider: # evTailCoeffSlider() NA # Return Value: return() } ################################################################################ fCopulae/inst/unitTests/runit.ArchimedeanGenerator.R0000644000176000001440000001230212406047540022351 0ustar ripleyusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA # Copyrights (C) # for this R-port: # 1999 - 2007, Diethelm Wuertz, GPL # Diethelm Wuertz # info@rmetrics.org # www.rmetrics.org # for the code accessed (or partly included) from other R-ports: # see R's copyright and license files # for the code accessed (or partly included) from contributed R-ports # and other sources # see Rmetrics's copyright file ################################################################################ # FUNCTION: ARCHIMEDEAN COPULAE PARAMETER: # evList Returns list of implemented extreme value copulae # archmParam Sets Default parameters for an extreme value copula # archmRange Returns the range of valid alpha values # archmCheck Checks if alpha is in the valid range # FUNCTION: ARCHIMEDEAN COPULAE PHI GENERATOR: # Phi Computes Archimedean Phi, inverse and derivatives # PhiSlider Displays interactively generator function # FUNCTION: ARCHIMEDEAN DENSITY K GENERATOR: # Kfunc Computes Archimedean Density Kc and its Inverse # KfuncSlider Displays interactively the density and concordance ################################################################################ test.archmList = function() { # Arguments: # archmList() # List: archmList() # Return Value: return() } # ------------------------------------------------------------------------------ test.archmParam = function() { # Arguments: # archmParam(type = archmList()) # Parameters: for (type in archmList()) { cat("\n") print(unlist(archmParam(type))) } # Return Value: return() } # ------------------------------------------------------------------------------ test.archmRange = function() { # Arguments: # archmRange(type = archmList(), B = Inf) # Range: for (type in archmList()) { cat("\n") print(archmRange(type)) } # Return Value: return() } # ------------------------------------------------------------------------------ test.archmCheck = function() { # Arguments ? # archmCheck(alpha, type = archmList()) # Check: for (type in archmList()) { cat("\n") print(archmCheck(archmParam(type)$param)) } # Return Value: return() } ################################################################################ test.Phi = function() { # Arguments: # Phi(x, alpha = NULL, type = archmList(), inv = FALSE, deriv = paste(0:2)) # Call Generator Function Phi: for (type in paste(1:22)) { print(Phi(x = 0.5, type = type, inv = TRUE, deriv = "0")) cat("\n") } for (type in paste(1:22)) { print(Phi(x = 0.5, type = type, inv = TRUE, deriv = "1")) cat("\n") } for (type in paste(1:22)) { print(Phi(x = 0.5, type = type, inv = TRUE, deriv = "2")) cat("\n") } for (type in paste(1:22)) { print(Phi(x = 0.5, type = type, inv = FALSE, deriv = "0")) cat("\n") } for (type in paste(1:22)) { print(Phi(x = 0.5, type = type, inv = FALSE, deriv = "1")) cat("\n") } for (type in paste(1:22)) { print(Phi(x = 0.5, type = type, inv = FALSE, deriv = "2")) cat("\n") } # Return Value: return() } # ------------------------------------------------------------------------------ test.PhiSlider = function() { # Arguments: # PhiSlider() # Try Slider: # PhiSlider() NA # Return Value: return() } ################################################################################ test.Kfunc = function() { # Arguments: # Kfunc(x, alpha = NULL, type = archmList(), inv = FALSE, lower = 1e-08) # Call Generator Function Phi: for (type in paste(1:22)) { print(Kfunc(x = 0.5, inv = FALSE)) cat("\n") } for (type in paste(1:22)) { print(Kfunc(x = 0.5, inv = TRUE)) cat("\n") } # Return Value: return() } # ------------------------------------------------------------------------------ test.KfuncSlider = function() { # Arguments: # KfuncSlider() # Try Slider: # KfuncSlider() NA # Return Value: return() } ################################################################################ fCopulae/inst/unitTests/runTests.R0000644000176000001440000000453012406047540016775 0ustar ripleyuserspkg <- "fCopulae" if(require("RUnit", quietly = TRUE)) { library(package=pkg, character.only = TRUE) if(!(exists("path") && file.exists(path))) path <- system.file("unitTests", package = pkg) ## --- Testing --- ## Define tests testSuite <- defineTestSuite(name = paste(pkg, "unit testing"), dirs = path) if(interactive()) { cat("Now have RUnit Test Suite 'testSuite' for package '", pkg, "' :\n", sep='') str(testSuite) cat('', "Consider doing", "\t tests <- runTestSuite(testSuite)", "\nand later", "\t printTextProtocol(tests)", '', sep = "\n") } else { ## run from shell / Rscript / R CMD Batch / ... ## Run tests <- runTestSuite(testSuite) if(file.access(path, 02) != 0) { ## cannot write to path -> use writable one tdir <- tempfile(paste(pkg, "unitTests", sep="_")) dir.create(tdir) pathReport <- file.path(tdir, "report") cat("RUnit reports are written into ", tdir, "/report.(txt|html)", sep = "") } else { pathReport <- file.path(path, "report") } ## Print Results: printTextProtocol(tests, showDetails = FALSE) printTextProtocol(tests, showDetails = FALSE, fileName = paste(pathReport, "Summary.txt", sep = "")) printTextProtocol(tests, showDetails = TRUE, fileName = paste(pathReport, ".txt", sep = "")) ## Print HTML Version to a File: ## printHTMLProtocol has problems on Mac OS X if (Sys.info()["sysname"] != "Darwin") printHTMLProtocol(tests, fileName = paste(pathReport, ".html", sep = "")) ## stop() if there are any failures i.e. FALSE to unit test. ## This will cause R CMD check to return error and stop tmp <- getErrors(tests) if(tmp$nFail > 0 | tmp$nErr > 0) { stop(paste("\n\nunit testing failed (#test failures: ", tmp$nFail, ", R errors: ", tmp$nErr, ")\n\n", sep="")) } } } else { cat("R package 'RUnit' cannot be loaded -- no unit tests run\n", "for package", pkg,"\n") } ################################################################################ fCopulae/inst/obsolete/0000755000176000001440000000000012406047540014633 5ustar ripleyusersfCopulae/inst/obsolete/src/0000755000176000001440000000000012406047540015422 5ustar ripleyusersfCopulae/inst/obsolete/src/adapt_callback.c0000644000176000001440000000303312406047540020472 0ustar ripleyusers#include "S.h" #include "Rinternals.h" /* Added declaration of FORTRAN by Yohan Chalabi */ void F77_NAME(adapt)(int*, /* ndim */ double*, /* lower */ double*, /* upper */ int*, /* minpts */ int*, /* maxpts */ double*, /* eps */ double*, /* relerr */ int*, /* lenwrk */ double*, /* wrkstr */ double*, /* finest */ int*); /* ifail */ static SEXP rho; static SEXP f; /* All this routine does is call the approriate fortran function. We need this so as to properly pass the S function */ /* changed to doubles for R by Thomas Lumley */ void cadapt(int *ndim, double *lower, double *upper, int *minpts, int *maxpts, void *functn, void *env, double *eps, double *relerr, int *lenwrk, double *finest, int *ifail) { double *wrkstr; wrkstr = (double *) S_alloc(*lenwrk, sizeof(double)); /* store the R function and its environment */ rho=env; f=functn; F77_CALL(adapt)(ndim,lower,upper,minpts,maxpts,eps,relerr,lenwrk, wrkstr,finest,ifail); } /* This is the fixed routine called by adapt */ /* changed to double for R, also rewritten to use eval() */ double F77_NAME(adphlp)(int *ndim, double *z) { SEXP args,resultsxp,callsxp; double result; int i; PROTECT(args=allocVector(REALSXP,*ndim)); for (i=0;i<*ndim;i++){ REAL(args)[i]=z[i]; } PROTECT(callsxp=lang2( f,args)); PROTECT(resultsxp=eval(callsxp,rho)); result=REAL(resultsxp)[0]; UNPROTECT(3); return(result); } fCopulae/inst/obsolete/src/adapt2.f0000644000176000001440000005111712406047540016751 0ustar ripleyusersCDW The multivariate integration package adapt was added to for use in the CDW Rmetrics package fCopula. Thanks to Prof. Alan Genz who put his code CDW for the use in fCopulae under the GPL-2 License. CDW Message-ID: <4AD7A74B.3020108@math.wsu.edu> CDW Date: Thu, 15 Oct 2009 15:50:51 -0700 CDW From: Alan Genz CDW User-Agent: Mozilla/5.0 (X11; U; Linux i686; en-US; rv:1.8.1.21) CDW Gecko/20090402 SeaMonkey/1.1.16 CDW MIME-Version: 1.0 CDW To: Diethelm Wuertz CDW CC: Alan C Genz CDW Subject: Re: adapt CDW References: <4AD3032B.4090801@itp.phys.ethz.ch> CDW In-Reply-To: <4AD3032B.4090801@itp.phys.ethz.ch> CDW Content-Type: text/plain; charset=ISO-8859-1; format=flowed CDW Content-Transfer-Encoding: 7bit CDW Status: O CDW Dear Prof. Wuertz, CDW Thank you for your message and your interest in my adaptive integration CDW Fortran code. I would be pleased if you included my code in your open CDW source R fCopulae package under the Gnu GPL2 license. You have my CDW permission to do this. CDW Sincerely, CDW Alan Genz cMM this is the original adapt code with one modification. cMM instead of calling the external function "functn", a fixed cMM external routine adphlp is always called, and passed a pointer cMM to the external s function. cMM Michael Meyer, October 1989. subroutine adapt(ndim,a,b,minpts,maxpts,eps,relerr, * lenwrk,wrkstr,finest,ifail) c***begin prologue adapt c adaptive multidimensional integration subroutine c author: A. C. Genz, Washington State University c 19 March 1984 c************** parameters for adapt ******************************** c***** input parameters c ndim number of variables, must exceed 1, but not exceed 20 c a real array of lower limits, with dimension ndim c b real array of upper limits, with dimension ndim c minpts minimum number of function evaluations to be allowed. c on the first call to adapt minpts should be set to a c non negative value (caution... minpts is altered by adapt). c It is possible to continue a calculation to greater accuracy c by calling adapt again by decreasing eps (described below) c and resetting minpts to any negative value. c minpts must not exceed maxpts. c maxpts maximum number of function evaluations to be allowed, c which must be at least rulcls, where c rulcls = 2**ndim+2*ndim**2+6*ndim+1 c c for ndim = 2 3 4 5 6 7 8 9 10 12 15 20 c maxpts >= rulcls = 25 45 73 113 173 269 433 729 1285 4457 33309 1049497 c c a SUGGESTED value for maxpts is 100 times the above values. c c functn externally declared user defined function to be integrated. c it must have parameters (ndim,z), where z is a real array c of dimension ndim. cTSL this function has been replaced by the fixed function adhlp c eps required relative accuracy c lenwrk length of array wrkstr of working storage, the routine c needs (2*ndim+3)*(1+maxpts/rulcls)/2 for lenwrk if c maxpts function calls are used. c for guidance, if you set maxpts to 100*rulcls (see table c above) then acceptable values for lenwrk are c c for ndim = 2 3 4 5 6 7 8 9 c lenwrk = 357 561 1785 3417 6681 13209 26265 52377 c c***** OUTPUT parameters c c minpts actual number of function evaluations used by adapt c wrkstr real array of working storage of dimension (lenwrk). c relerr estimated relative accuracy of finest c finest estimated value of integral ["FINal ESTimate"] c ifail : return code c c ifail=0 for normal exit, when estimated relative accuracy c relerr is less than eps with maxpts or less function c calls made. c ifail=1 if maxpts was too small for adapt to obtain the c required relative accuracy eps. c In this case adapt returns a value of finest c with estimated relative accuracy relerr. c ifail=2 if lenwrk too small for maxpts function calls. c In this case adapt returns a value of finest with c estimated accuracy relerr using the working storage c available, but relerr will be greater than eps. c ifail=3 if ndim < 2, ndim > 20, c ifail=4 if minpts > maxpts, c ifail=5 if maxpts < rulcls or other memory problems c (which will only be found later) c*********************************************************************** c***end prologue adapt implicit none C-- Arguments: C double precision functn C external functn integer ndim, minpts,maxpts, lenwrk, ifail double precision a(ndim), b(ndim), eps, relerr, wrkstr(lenwrk), & finest C-- Local Variables: double precision center(20), width(20) double precision errmin, rgnerr, rgnval, half, zero,one,two integer divaxo, divaxn, divflg, funcls, index1, index2, * j, k, maxcls, rgnstr, rulcls, sbrgns, sbtmpp, subrgn, subtmp data zero/0d0/, one/1d0/, two/2d0/ c Check arguments; fail w/ code '3' or '4' relerr=one funcls=0 ifail=3 if(ndim.lt.2.or.ndim.gt.20) goto 990 ifail=4 if(minpts.gt.maxpts) goto 990 ifail=5 c c***** initialisation of subroutine c half=one/two rgnstr =2*ndim+3 errmin = zero maxcls = 2**ndim + 2*ndim**2 + 6*ndim+1 maxcls = min0(maxcls,maxpts) divaxo=0 c c***** end subroutine initialisation if(minpts.lt.0) then sbrgns=wrkstr(lenwrk-1) goto 280 endif do 30 j=1,ndim width(j)=(b(j)-a(j))*half 30 center(j)=a(j)+width(j) finest=zero wrkstr(lenwrk)=zero divflg=1 subrgn=rgnstr sbrgns=rgnstr C-- REPEAT --- (outermost loop) ------- 40 call bsrl(ndim,center,width,maxcls,rulcls, * errmin,rgnerr,rgnval,divaxo,divaxn) finest=finest+rgnval wrkstr(lenwrk)=wrkstr(lenwrk)+rgnerr funcls = funcls + rulcls c c***** place results of basic rule into partially ordered list c***** according to subregion error if(divflg .eq. 0) then c c***** when divflg=0 start at top of list and move down list tree to c find correct position for results from first half of recently c divided subregion 200 subtmp=2*subrgn if(subtmp.le.sbrgns) then if(subtmp.ne.sbrgns) then sbtmpp=subtmp+rgnstr if(wrkstr(subtmp).lt.wrkstr(sbtmpp)) subtmp=sbtmpp endif 210 if(rgnerr.lt.wrkstr(subtmp)) then do 220 k=1,rgnstr index1=subrgn-k+1 index2=subtmp-k+1 wrkstr(index1)=wrkstr(index2) 220 continue subrgn=subtmp goto 200 endif endif else c c*****when divflg=1 start at bottom right branch and move up list c tree to find correct position for results from second half of c recently divided subregion 230 subtmp=(subrgn/(rgnstr*2))*rgnstr if(subtmp.ge.rgnstr) then if(rgnerr.gt.wrkstr(subtmp)) then do 240 k=1,rgnstr index1=subrgn-k+1 index2=subtmp-k+1 wrkstr(index1)=wrkstr(index2) 240 continue subrgn=subtmp goto 230 endif endif endif c***** store results of basic rule in correct position in list 250 wrkstr(subrgn)=rgnerr wrkstr(subrgn-1)=rgnval wrkstr(subrgn-2)=divaxn do 260 j=1,ndim subtmp=subrgn-2*(j+1) wrkstr(subtmp+1)=center(j) wrkstr(subtmp)=width(j) 260 continue if(divflg .eq. 0) then c*** when divflg=0 prepare for second application of basic rule center(divaxo)=center(divaxo)+two*width(divaxo) sbrgns=sbrgns+rgnstr subrgn=sbrgns divflg=1 c*** loop back to apply basic rule to other half of subregion go to 40 endif c c***** end ordering and storage of basic rule results c***** make checks for possible termination of routine c 270 relerr=one if(wrkstr(lenwrk).le.zero) wrkstr(lenwrk)=zero if(dabs(finest).ne.zero) relerr=wrkstr(lenwrk)/dabs(finest) if(relerr.gt.one) relerr=one if(sbrgns+rgnstr.gt.lenwrk-2) ifail=2 if(funcls+funcls*rgnstr/sbrgns.gt.maxpts) ifail=1 if(relerr.lt.eps.and.funcls.ge.minpts) ifail=0 if(ifail.lt.3) goto 990 c c***** prepare to use basic rule on each half of subregion with largest c error 280 divflg=0 subrgn=rgnstr subtmp = 2*sbrgns/rgnstr maxcls = maxpts/subtmp errmin = dabs(finest)*eps/dfloat(subtmp) wrkstr(lenwrk)=wrkstr(lenwrk)-wrkstr(subrgn) finest=finest-wrkstr(subrgn-1) divaxo=wrkstr(subrgn-2) do 290 j=1,ndim subtmp=subrgn-2*(j+1) center(j)=wrkstr(subtmp+1) 290 width(j)=wrkstr(subtmp) width(divaxo)=width(divaxo)*half center(divaxo)=center(divaxo)-width(divaxo) c c***** loop back to apply basic rule c goto 40 c c***** termination point c 990 minpts=funcls wrkstr(lenwrk-1)=sbrgns return end subroutine bsrl(s, center,hwidth, maxvls,funcls, * errmin,errest,basest,divaxo,divaxn) implicit none C-- Arguments: integer s double precision center(s), hwidth(s) integer maxvls,funcls, divaxo,divaxn double precision errmin, errest, basest C EXTERNAL adphlp double precision adphlp C-- Local Variables: double precision intvls(20), z(20), fulsms(200), weghts(200) integer intcls, i, mindeg, maxdeg, maxord, minord integer ifail double precision zero, one, two, ten, dif, errorm, * sum0, sum1, sum2, difmax, x1, x2 data zero/0d0/, one/1d0/, two/2d0/, ten/10d0/ maxdeg = 12 mindeg = 4 minord = 0 do 10 maxord = mindeg,maxdeg call symrl(s, center, hwidth, minord, maxord, intvls, * intcls, 200, weghts, fulsms, ifail) if (ifail.eq.2) goto 20 errest = dabs(intvls(maxord) -intvls(maxord-1)) errorm = dabs(intvls(maxord-1)-intvls(maxord-2)) if (errest.ne.zero) & errest = errest* & dmax1(one/ten,errest/dmax1(errest/two,errorm)) if (errorm.le. 5.*errest) goto 20 if (2*intcls.gt.maxvls) goto 20 if (errest.lt.errmin) goto 20 10 continue 20 difmax = -1 x1 = one/two**2 x2 = 3.*x1 do 30 i = 1,s z(i) = center(i) 30 continue cmmm sum0 = adphlp(s,z) do 40 i = 1,s z(i) = center(i) - x1*hwidth(i) cmmm sum1 = adphlp(s,z) z(i) = center(i) + x1*hwidth(i) sum1 = sum1 + adphlp(s,z) z(i) = center(i) - x2*hwidth(i) sum2 = adphlp(s,z) z(i) = center(i) + x2*hwidth(i) sum2 = sum2 + adphlp(s,z) z(i) = center(i) dif = dabs((sum1-two*sum0) - (x1/x2)**2*(sum2-two*sum0)) if (dif.ge.difmax) then difmax = dif divaxn = i endif 40 continue if (sum0.eq.sum0+difmax/two) divaxn = mod(divaxo,s) + 1 basest = intvls(minord) funcls = intcls + 4*s return end double precision function flsm(s,center,hwidth,x,m,mp,maxord, * g,sumcls) c c*** function to compute fully symmetric basic rule sum c integer s, m(s), mp(s), maxord, sumcls, ixchng, lxchng, i, l, * ihalf, mpi, mpl double precision g(maxord), x(s), intwgt, zero, one,two, intsum, * center(s), hwidth(s) double precision adphlp zero = 0 one = 1 two = 2 intwgt = one do 10 i=1,s mp(i) = m(i) if (m(i).ne.0) intwgt = intwgt/two intwgt = intwgt*hwidth(i) 10 continue sumcls = 0 flsm = zero c c******* compute centrally symmetric sum for permutation mp 20 intsum = zero do 30 i=1,s mpi = mp(i) + 1 x(i) = center(i) + g(mpi)*hwidth(i) 30 continue 40 sumcls = sumcls + 1 cmmm intsum = intsum + adphlp(s,x) do 50 i=1,s mpi = mp(i) + 1 if(g(mpi).ne.zero) hwidth(i) = -hwidth(i) x(i) = center(i) + g(mpi)*hwidth(i) if (x(i).lt.center(i)) go to 40 50 continue c******* end integration loop for mp c flsm = flsm + intwgt*intsum if (s.eq.1) return c c******* find next distinct permutation of m and loop back c to compute next centrally symmetric sum do 80 i=2,s if (mp(i-1).le.mp(i)) go to 80 mpi = mp(i) ixchng = i - 1 if (i.eq.2) go to 70 ihalf = ixchng/2 do 60 l=1,ihalf mpl = mp(l) imnusl = i - l mp(l) = mp(imnusl) mp(imnusl) = mpl if (mpl.le.mpi) ixchng = ixchng - 1 if (mp(l).gt.mpi) lxchng = l 60 continue if (mp(ixchng).le.mpi) ixchng = lxchng 70 mp(i) = mp(ixchng) mp(ixchng) = mpi go to 20 80 continue c***** end loop for permutations of m and associated sums c return end subroutine nxprt(prtcnt, s, m) c c*** subroutine to compute the next s partition c implicit none integer s, m(s), prtcnt integer i,k, msum if (prtcnt.gt.0) go to 20 do 10 i=1,s m(i) = 0 10 continue prtcnt = 1 return 20 prtcnt = prtcnt + 1 msum = m(1) if (s.eq.1) go to 60 do 50 i=2,s msum = msum + m(i) if (m(1).le.m(i)+1) go to 40 m(1) = msum - (i-1)*(m(i)+1) do 30 k=2,i m(k) = m(i) + 1 30 continue return 40 m(i) = 0 50 continue 60 m(1) = msum + 1 return end subroutine symrl(s, center, hwidth, minord, maxord, intvls, * intcls, numsms, weghts, fulsms, fail) c multidimensional fully symmetric rule integration subroutine c c this subroutine computes a sequence of fully symmetric rule c approximations to a fully symmetric multiple integral. c written by a. genz, mathematical institute, university of kent, c canterbury, kent ct2 7nf, england c c************** parameters for symrl ******************************** c*****input parameters c s integer number of variables, must exceed 0 but not exceed 20 c f externally declared user defined real function integrand. c it must have parameters (s,x), where x is a real array c with dimension s. c minord integer minimum order parameter. on entry minord specifies c the current highest order approximation to the integral, c available in the array intvls. for the first call of symrl c minord should be set to 0. otherwise a previous call is c assumed that computed intvls(1), ... , intvls(minord). c on exit minord is set to maxord. c maxord integer maximum order parameter, must be greater than minord c and not exceed 20. the subroutine computes intvls(minord+1), c intvls(minord+2),..., intvls(maxord). c g real array of dimension(maxord) of generators. c all generators must be distinct and nonnegative. c numsms integer length of array fulsms, must be at least the sum of c the number of distinct partitions of length at most s c of the integers 0,1,...,maxord-1. an upper bound for numsms c when s+maxord is less than 19 is 200 c******output parameters c intvls real array of dimension(maxord). upon successful exit c intvls(1), intvls(2),..., intvls(maxord) are approximations c to the integral. intvls(d+1) will be an approximation of c polynomial degree 2d+1. c intcls integer total number of f values needed for intvls(maxord) c weghts real working storage array with dimension (numsms). on exit c weghts(j) contains the weight for fulsms(j). c fulsms real working storage array with dimension (numsms). on exit c fulsms(j) contains the fully symmetric basic rule sum c indexed by the jth s-partition of the integers c 0,1,...,maxord-1. c fail integer failure output parameter c fail=0 for successful termination of the subroutine c fail=1 when numsms is too small for the subroutine to c continue. in this case weghts(1), weghts(2), ..., c weghts(numsms), fulsms(1), fulsms(2), ..., c fulsms(numsms) and intvls(1), intvls(2),..., c intvls(j) are returned, where j is maximum value of c maxord compatible with the given value of numsms. c fail=2 when parameters s,minord, maxord or g are out of c range c*********************************************************************** cmmm external f ctsl real f ctsl double precision f c*** for double precision change real to double precision c in the next statement integer d, i, fail, k(20), intcls, prtcnt, l, m(20), maxord, * minord, modofm, numsms, s, sumcls double precision intvls(maxord), center(s), hwidth(s), gisqrd, * glsqrd, * intmpa, intmpb, intval, one, fulsms(numsms), weghts(numsms), * two, momtol, momnkn, momprd(20,20), moment(20), zero, g(20) double precision flsm, wht c patterson generators data g(1), g(2) /0.0000000000000000,0.7745966692414833/ data g(3), g(4) /0.9604912687080202,0.4342437493468025/ data g(5), g(6) /0.9938319632127549,0.8884592328722569/ data g(7), g(8) /0.6211029467372263,0.2233866864289668/ data g(9), g(10), g(11), g(12) /0.1, 0.2, 0.3, 0.4/ c c*** parameter checking and initialisation fail = 2 maxrdm = 20 maxs = 20 if (s.gt.maxs .or. s.lt.1) return if (minord.lt.0 .or. minord.ge.maxord) return if (maxord.gt.maxrdm) return zero = 0 one = 1 two = 2 momtol = one 10 momtol = momtol/two if (momtol+one.gt.one) go to 10 hundrd = 100 momtol = hundrd*two*momtol d = minord if (d.eq.0) intcls = 0 c*** calculate moments and modified moments do 20 l=1,maxord floatl = l + l - 1 moment(l) = two/floatl 20 continue if (maxord.ne.1) then do 40 l=2,maxord intmpa = moment(l-1) glsqrd = g(l-1)**2 do 30 i=l,maxord intmpb = moment(i) moment(i) = moment(i) - glsqrd*intmpa intmpa = intmpb 30 continue if (moment(l)**2.lt.(momtol*moment(1))**2) moment(l) = zero 40 continue endif do 70 l=1,maxord if (g(l).lt.zero) return momnkn = one momprd(l,1) = moment(1) if (maxord.eq.1) go to 70 glsqrd = g(l)**2 do 60 i=2,maxord if (i.le.l) gisqrd = g(i-1)**2 if (i.gt.l) gisqrd = g(i)**2 if (glsqrd.eq.gisqrd) return momnkn = momnkn/(glsqrd-gisqrd) momprd(l,i) = momnkn*moment(i) 60 continue 70 continue fail = 1 c c*** begin LOOP c for each d find all distinct partitions m with mod(m))=d c 80 prtcnt = 0 intval = zero modofm = 0 call nxprt(prtcnt, s, m) 90 if (prtcnt.gt.numsms) return c c*** calculate weight for partition m and fully symmetric sums c*** when necessary c if (d.eq.modofm) weghts(prtcnt) = zero if (d.eq.modofm) fulsms(prtcnt) = zero fulwgt = wht(s,moment,m,k,modofm,d,maxrdm,momprd) sumcls = 0 if (weghts(prtcnt).eq.zero .and. fulwgt.ne.zero) fulsms(prtcnt) = * flsm(s, center, hwidth, moment, m, k, maxord, g, sumcls) intcls = intcls + sumcls intval = intval + fulwgt*fulsms(prtcnt) weghts(prtcnt) = weghts(prtcnt) + fulwgt call nxprt(prtcnt, s, m) if (m(1).gt.modofm) modofm = modofm + 1 if (modofm.le.d) go to 90 c c*** end loop for each d if (d.gt.0) intval = intvls(d) + intval intvls(d+1) = intval d = d + 1 if (d.lt.maxord) go to 80 c c*** set failure parameter and return fail = 0 minord = maxord return end double precision function wht(s, intrps, m, k, modofm, d, * maxrdm, momprd) c*** subroutine to calculate weight for partition m c integer s, m(s), k(s), d, maxrdm, mi, ki, m1, k1, modofm double precision intrps(s), zero, momprd(maxrdm,maxrdm) zero = 0 do 10 i=1,s intrps(i) = zero k(i) = 0 10 continue m1 = m(1) + 1 k1 = d - modofm + m1 20 intrps(1) = momprd(m1,k1) if (s.eq.1) go to 40 do 30 i=2,s mi = m(i) + 1 ki = k(i) + mi intrps(i) = intrps(i) + momprd(mi,ki)*intrps(i-1) intrps(i-1) = zero k1 = k1 - 1 k(i) = k(i) + 1 if (k1.ge.m1) go to 20 k1 = k1 + k(i) k(i) = 0 30 continue 40 wht = intrps(s) return end fCopulae/inst/obsolete/R/0000755000176000001440000000000012406047540015034 5ustar ripleyusersfCopulae/inst/obsolete/R/mv-distributions.R0000644000176000001440000004006612406047540020507 0ustar ripleyusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA # Copyrights (C) # for this R-port: # 1999 - 2007, Diethelm Wuertz, GPL # Diethelm Wuertz # info@rmetrics.org # www.rmetrics.org # for the code accessed (or partly included) from other R-ports: # see R's copyright and license files # for the code accessed (or partly included) from contributed R-ports # and other sources # see Rmetrics's copyright file ################################################################################ # FUNCTION: PARAMETER ESTIMATION: # fMV S4 Object of class 'fMV' # mvFit Fits a MV Normal or Student-t Distribution # print.fMV S3: Print method for objects of class 'fMV' # plot.fMV S3: Plot method for objects of class 'fMV' # summary.fMV S3: Summary method for objects of class 'fMV' # .mvnormFit Fits a Multivariate Normal Distribution # .mvstFit Fits a Multivariate Student-t Distribution # .mvsnormPlot Plots for Multivariate Normal Distribution # .mvstPlot Plots for Multivariate Student-t Distribution # REQUIREMENTS: DESCRIPTION: # "mvtnorm" Contributed R - Package # "sn" | "mnormt" Contributed R - Package ################################################################################ ################################################################################ # PARAMETER FIT: setClass("fMV", representation( call = "call", method = "character", model = "list", data = "data.frame", fit = "list", title = "character", description = "character") ) # ------------------------------------------------------------------------------ mvFit = function(x, method = c("snorm", "st"), fixed.df = NA, title = NULL, description = NULL, trace = FALSE, ...) { # A function implemented by Diethelm Wuertz # Description: # FUNCTION: # Fit: if (method[1] == "snorm") { # Normal Fit: fit = .mvsnormFit(x = x, trace = trace, ...) fit$df = Inf } if (method[1] == "st") { # Student-t Fit: fit = .mvstFit(x = x, fixed.df = fixed.df, trace = trace, ...) } # Add to fit: fit$method = method[1] class(fit) = "list" # Model Slot: model = list(beta = fit$beta, Omega = fit$Omega, alpha = fit$alpha, df = fit$df) # Title Slot: if (is.null(title)) { if (method[1] == "snorm") title = "Multivariate Normal Distribution" if (method[1] == "st") title = "Multivariate Student-t Distribution" } # Description Slot: if (is.null(description)) description = description() # Return Value: new("fMV", call = as.call(match.call()), method = as.character(method[1]), model = model, data = as.data.frame(x), fit = fit, title = as.character(title), description = as.character(description) ) } # ------------------------------------------------------------------------------ setMethod("show", "fMV", function(object) { # A function implemented by Diethelm Wuertz # Description: # Arguments: # FUNCTION: # Extract fit: fit = object@fit # Print: cat("\nCall:\n ") print.default(fit$call) cat("\nParameter Sstimates:\n") print.default(fit$dp) cat("\nParameter Errors:\n") print.default(fit$se) # cat("\nOptimization:\n") # print.default(fit$optim) }) # ------------------------------------------------------------------------------ plot.fMV = function(x, which = "ask", ...) { # A function implemented by Diethelm Wuertz # Description: # Arguments: # FUNCTION: # Plot: if (x@fit$method == "snorm") { # Multivariate Skew Normal Distribution: return(.mvsnormPlot(x = x@fit, which = which, ...)) } if (x@fit$method == "st") { # Multivariate Skew Student-t Distribution: return(.mvstPlot(x = x@fit, which = which, ...)) } } # ------------------------------------------------------------------------------ summary.fMV = function(object, which = "ask", doplot = TRUE, ...) { # A function implemented by Diethelm Wuertz # Description: # Arguments: # FUNCTION: # Print: print(x = object, ...) # Plot: if (doplot) plot(x = object, which = which, doplot, ...) # Return Value: invisible(object) } ################################################################################ # INERNAL FUNCTIONS: .mvsnormFit = function(x, trace = FALSE, ...) { # A function implemented by Diethelm Wuertz # Description: # Internal Function # Arguments: # FUNCTION: # Settings: y = x y.name = deparse(substitute(y)) y.names = dimnames(y)[[2]] y = as.matrix(y) colnames(y) = y.names k = ncol(y) freq = rep(1, nrow(y)) n = sum(freq) X = rep(1, nrow(y)) X = as.matrix(X) m = ncol(X) dimnames(y) = list(NULL, outer("V", as.character(1:k), paste, sep = "")) y.names = as.vector(dimnames(y)[[2]]) qrX = qr(X) # Fit: mle = msn.mle(X = X, y = y, freq = freq, trace = trace, ...) mle$call = match.call() mle$y = y mle$y.names = y.names # Parameters: mle$beta = beta = mle$dp$beta mle$xi = xi = X %*% beta mle$Omega = Omega = mle$dp$Omega mle$alpha = alpha = mle$dp$alpha # Test: # dev.norm = msn.dev(c(qr.coef(qrX, y), rep(0, k)), X, y, freq) # test = dev.norm + 2 * mle$logL # p.value = 1 - pchisq(test, k) # mle$test.normality = list(LRT = test, p.value = p.value) # Save for Plot: Xb = qr.fitted(qrX, y) res = qr.resid(qrX, y) mle$k = k mle$n = n mle$pp = qchisq((1:n)/(n + 1), k) mle$rad.n = apply((y - Xb) * ((y - Xb) %*% solve(var(res))), 1, sum) mle$rad.sn = apply((y - xi) * ((y - xi) %*% solve(Omega)), 1, sum) # Return Value: class(mle) = "snFit" mle } # ------------------------------------------------------------------------------ .mvstFit = function(x, fixed.df = NA, trace = FALSE, ...) { # A function implemented by Diethelm Wuertz # Description: # Internal Function # Arguments: # FUNCTION: # Settings: y = as.matrix(x) k = ncol(y) y.name = deparse(substitute(y)) dimnames(y) = list(NULL, outer("V", as.character(1:k), paste, sep = "")) y.names = dimnames(y)[[2]] freq = rep(1, nrow(y)) n = sum(freq) X = as.matrix(rep(1, nrow(y))) qrX = qr(X) m = ncol(X) # Fit: mle = mst.mle(X = X, y = y, freq = freq, fixed.df = fixed.df, trace = trace, ...) mle$call = match.call() mle$y = y mle$y.names = y.names # Parameters: mle$beta = beta = mle$dp$beta mle$xi = xi = X %*% beta mle$Omega = Omega = mle$dp$Omega mle$alpha = alpha = mle$dp$alpha mle$df = df = mle$dp$df # Save for Plot: Xb = qr.fitted(qrX, y) res = qr.resid(qrX, y) mle$k = k mle$n = n mle$pp = k * qf((1:n)/(n + 1), k, df) mle$rad.n = as.vector(apply(res * (res %*% solve(var(res))), 1, sum)) mle$rad.sn = as.vector(apply((y - xi)*((y - xi) %*% solve(Omega)), 1, sum)) # Return Value: class(mle) = "stFit" mle } # ------------------------------------------------------------------------------ .mvsnormPlot = function(x, which = "ask", ...) { # A function implemented by Diethelm Wuertz # Description: # Internal Plot Function # Arguments: # x - the slot @fit from an object of class "fMV" # FUNCTION: # Settings: dim = ncol(x$y) # Plot Title: plot1Title = "Scatterplots" if (dim == 1) plot1Title = "Histogram Plot" # Plot: interactivePlot( x = x, choices = c( plot1Title, "Normal QQ-Plot", "Skew-Normal QQ-Plot", "Normal PP-Plot", "Skew-Normal PP-Plot"), plotFUN = c( ".mvsnorm.plot.1", ".mvsnorm.plot.2", ".mvsnorm.plot.3", ".mvsnorm.plot.4", ".mvsnorm.plot.5"), which = which) # Return Value: invisible(x) } # ------------------------------------------------------------------------------ .mvsnorm.plot.1 <- function(x) { # Plot: dim = x$k if(dim == 1) .mvsnorm.plot.1A(x) else .mvsnorm.plot.1B(x) } # ------------------------------------------------------------------------------ .mvsnorm.plot.1A <- function(x) { # Plot: z = x y0 <- z$y xi0 <- apply(z$xi, 2, mean) y0 <- as.vector(y0) x <- seq(min(pretty(y0, 10)), max(pretty(y0, 10)), length = 100) omega <- sqrt(diag(z$Omega)) dp0 <- c(xi0, omega, z$alpha) xlab <- z$y.name hist(y0, prob = TRUE, breaks = "FD", xlab = xlab, ylab = "density", border = "white", col = "steelblue4", main = z$y.name) lines(x, dsn(x, dp0[1], dp0[2], dp0[3])) if (length(y0) < 201) points(y0, rep(0, z$n), pch = 1) } # ------------------------------------------------------------------------------ .mvsnorm.plot.1B <- function(x) { # Plot: opt = options() options(warn = -1) pairs( x$y, labels = x$y.names, panel = function(x, y, Y, y.names, xi, Omega, alpha) { for (i in 1:length(alpha)) { if (all(Y[, i] == x)) Ix = i if (all(Y[, i] == y)) Iy = i } points(x, y) marg = msn.marginal(xi, Omega, alpha, c(Ix, Iy)) xi.marg = marg$xi Omega.marg = marg$Omega alpha.marg = marg$alpha x1 = seq(min(x), max(x), length = 30) x2 = seq(min(y), max(y), length = 30) dsn2.plot(x1, x2, xi.marg, Omega.marg, alpha.marg, add = TRUE, col = "steelblue4")}, Y = x$y, y.names = dimnames(x$y)[[2]], xi = apply(x$xi, 2, mean), Omega = x$Omega, alpha = x$alpha) options(opt) } # ------------------------------------------------------------------------------ .mvsnorm.plot.2 <- function(x) { # Plot: plot(x$pp, sort(x$rad.n), pch = 1, ylim = c(0, max(x$rad.n, x$rad.sn)), xlab = "Chi-square Percentiles", ylab = "Mahalanobis Distances") abline(0, 1, lty = 3) title(main = "Normal QQ-Plot", sub = x$y.name) } # ------------------------------------------------------------------------------ .mvsnorm.plot.3 <- function(x) { # Plot: plot(x$pp, sort(x$rad.sn), pch = 1, ylim = c(0, max(x$rad.n, x$rad.sn)), xlab = "Percentiles of chi-square distribution", ylab = "Mahalanobis distances") abline(0, 1, lty = 3) title(main = "Skew-Normal QQ-Plot", sub = x$y.name) } # ------------------------------------------------------------------------------ .mvsnorm.plot.4 <- function(x) { # Plot: plot((1:x$n)/(x$n + 1), sort(pchisq(x$rad.n, x$k)), xlab = "", ylab = "") abline(0, 1, lty = 3) title(main = "Normal PP-Plot", sub = x$y.name) } # ------------------------------------------------------------------------------ .mvsnorm.plot.5 <- function(x) { # Plot: plot((1:x$n)/(x$n + 1), sort(pchisq(x$rad.sn, x$k)), xlab = "", ylab = "") abline(0, 1, lty = 3) title(main = "Skew-Normal PP-Plot", sub = x$y.name) } # ------------------------------------------------------------------------------ .mvstPlot = function(x, which = "ask", ...) { # A function implemented by Diethelm Wuertz # Description: # Internal Plot Function # Arguments: # x - the slot @fit from an object of class "fMV" # FUNCTION: # Settings: dim = ncol(x$y) # Plot Title: plot1Title = "Scatterplots" if (dim == 1) plot1Title = "Histogram Plot" # Plot: plot1Title = "Scatterplots" if (dim == 1) plot1Title = "Histogram Plot" interactivePlot( x = x, choices = c( plot1Title, "Normal QQ-Plot", "Skew-Normal QQ-Plot", "Normal PP-Plot", "Skew-Normal PP-Plot"), plotFUN = c( ".mvst.plot.1", ".mvst.plot.2", ".mvst.plot.3", ".mvst.plot.4", ".mvst.plot.5"), which = which) # Return Value: invisible(x) } # ------------------------------------------------------------------------------ .mvst.plot.1 <- function(x) { # Plot: dim = x$k if(dim == 1) .mvst.plot.1A(x) else .mvst.plot.1B(x) } # ------------------------------------------------------------------------------ .mvst.plot.1A <- function(x) { # Plot: z = x y0 <- z$y xi0 <- apply(z$xi, 2, mean) y0 <- as.vector(y0) x <- seq(min(pretty(y0, 10)), max(pretty(y0, 10)), length = 100) omega <- sqrt(diag(z$Omega)) dp0 <- c(xi0, omega, z$alpha, z$df) xlab <- z$y.name hist(y0, prob = TRUE, breaks = "FD", xlab = xlab, ylab = "density", border = "white", col = "steelblue4", main = z$y.name) lines(x, dst(x, dp0[1], dp0[2], dp0[3], dp0[4])) if (length(y0) < 201) points(y0, rep(0, z$n), pch = 1) } # ------------------------------------------------------------------------------ .mvst.plot.1B <- function(x) { # Plot: opt = options() options(warn = -1) pairs( x$y, labels = x$y.names, panel = function(x, y, Y, y.names, xi, Omega, alpha, df) { for (i in 1:length(alpha)) { if (all(Y[, i] == x)) Ix = i if (all(Y[, i] == y)) Iy = i } points(x, y) marg = msn.marginal(xi, Omega, alpha, c(Ix, Iy)) xi.marg = marg$xi Omega.marg = marg$Omega alpha.marg = marg$alpha x1 = seq(min(x), max(x), length = 30) x2 = seq(min(y), max(y), length = 30) dst2.plot(x1, x2, xi.marg, Omega.marg, alpha.marg, df, add = TRUE, col = "steelblue4")} , Y = x$y, y.names = dimnames(x$y)[[2]], xi = apply(x$xi, 2, mean), Omega = x$Omega, alpha = x$alpha, df = x$df) options(opt) } # ------------------------------------------------------------------------------ .mvst.plot.2 <- function(x) { # Plot: plot(x$pp, sort(x$rad.n), pch = 1, ylim = c(0, max(x$rad.n, x$rad.sn)), xlab = "Chi-square Percentiles", ylab = "Mahalanobis Distances") abline(0, 1, lty = 3) title(main = "Normal QQ-Plot", sub = x$y.name) } # ------------------------------------------------------------------------------ .mvst.plot.3 <- function(x) { # Plot: plot(x$pp, sort(x$rad.sn), pch = 1, ylim = c(0, max(x$rad.n, x$rad.sn)), xlab = "Percentiles of chi-square distribution", ylab = "Mahalanobis distances") abline(0, 1, lty = 3) title(main = "Skew-Normal QQ-Plot", sub = x$y.name) } # ------------------------------------------------------------------------------ .mvst.plot.4 <- function(x) { # Plot: plot((1:x$n)/(x$n + 1), sort(pchisq(x$rad.n, x$k)), xlab = "", ylab = "") abline(0, 1, lty = 3) title(main = "Normal PP-Plot", sub = x$y.name) } # ------------------------------------------------------------------------------ .mvst.plot.5 <- function(x) { # Plot: plot((1:x$n)/(x$n + 1), sort(pchisq(x$rad.sn, x$k)), xlab = "", ylab = "") abline(0, 1, lty = 3) title(main = "Skew-Normal PP-Plot", sub = x$y.name) } ################################################################################ fCopulae/inst/obsolete/R/biv-density.R0000644000176000001440000001747712406047540017434 0ustar ripleyusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA # Copyrights (C) # for this R-port: # 1999 - 2007, Diethelm Wuertz, GPL # Diethelm Wuertz # info@rmetrics.org # www.rmetrics.org # for the code accessed (or partly included) from other R-ports: # see R's copyright and license files # for the code accessed (or partly included) from contributed R-ports # and other sources # see Rmetrics's copyright file ################################################################################ # FUNCTION: DESCRIPTION: # grid2d Returns from two vectors x-y grid coordinates # density2d Returns 2D Kernel Density Estimates # hist2d Returns 2D Histogram Counts # integrate2d Integrates over a two dimensional unit square ################################################################################ grid2d = function(x = (0:10)/10, y = x) { # A function implemented by Diethelm Wuertz # Description: # Creates from two vectors x-y grid coordinates # Arguments: # x, y - two numeric vectors defining the x and y coordinates. # Value: # returns a list with two vectors named $x and $y spanning the # grid defined by the coordinates x and y. # Example: # > grid2d(1:3, 1:2) # $x # [1] 1 2 3 1 2 3 # $y # [1] 1 1 1 2 2 2 # FUNCTION: # Prepare for Input: nx = length(x) ny = length(y) xoy = cbind(rep(x, ny), as.vector(matrix(y, nx, ny, byrow = TRUE))) XY = matrix(xoy, nx * ny, 2, byrow = FALSE) # Return Value: list(x = XY[, 1], y = XY[, 2]) } # ------------------------------------------------------------------------------ density2d = function (x, y = NULL, n = 20, h = NULL, limits = c(range(x), range(y))) { # A function implemented by Diethelm Wuertz # Description: # Returns 2D Kernel Density Estimates # Arguments: # x, y - two vectors of coordinates of data. If y is NULL then x # is assumed to be a two column matrix, where the first column # contains the x data, and the second column the y data. # n - Number of grid points in each direction. # h - a vector of bandwidths for x and y directions. Defaults to # normal reference bandwidth. # limits - the limits of the rectangle covered by the grid. # Value: # A list with three elements x, y, and z. x and y are vectors # spanning the two dimensioanl grid and z the corresponding # matrix. The output can directly serve as input to the # plotting functions image, contour and persp. # Details: # Two-dimensional kernel density estimation with an axis-aligned # bivariate normal kernel, evaluated on a square grid. # Note: # Partly copied from R Package MASS, function 'kde2d'. # Reference: # Venables, W.N., Ripley, B. D. (2002); # Modern Applied Statistics with S. # Fourth edition, Springer. # FUNCTION: # Settings: lims = limits if (is.null(y)) { y = x[, 2] x = x[, 1] } # Bandwidth: .bandwidth.nrd = function (x) { r = quantile(x, c(0.25, 0.75)) h = (r[2] - r[1])/1.34 4 * 1.06 * min(sqrt(var(x)), h) * length(x)^(-1/5) } # Kernel Density Estimator: nx = length(x) if (length(y) != nx) stop("Data vectors must be the same length") gx = seq(lims[1], lims[2], length = n) gy = seq(lims[3], lims[4], length = n) if (is.null(h)) h = c(.bandwidth.nrd(x), .bandwidth.nrd(y)) h = h/4 ax = outer(gx, x, "-")/h[1] ay = outer(gy, y, "-")/h[2] z = matrix(dnorm(ax), n, nx) %*% t(matrix(dnorm(ay), n, nx))/(nx * h[1] * h[2]) # Return Value: list(x = gx, y = gy, z = z) } # ------------------------------------------------------------------------------ hist2d = function(x, y = NULL, n = c(20, 20)) { # A function implemented by Diethelm Wuertz # Description: # Returns 2D Histogram Counts # Arguments: # x, y - two vectors of coordinates of data. If y is NULL then x # is assumed to be a two column matrix, where the first column # contains the x data, and the second column the y data. # n - number of bins in each dimension, may be a scalar or a 2 # element vector. The default value is 20. # Value: # A list with three elements x, y, and z. x and y are vectors # spanning the two dimensioanl grid and z the corresponding # matrix. The output can directly serve as input to the # plotting functions image, contour and persp. # Note: # Partly copied from R Package gregmisc, function 'hist2d'. # FUNCTION: # 2D Histogram Counts: if (is.null(y)) { y = x[, 2] x = x[, 1] } if (length(n) == 1) { nbins = c(n, n) } else { nbins = n } nas = is.na(x) | is.na(y) x.cuts = seq(from = min(x, y), to = max(x,y), length = nbins[1]+1) y.cuts = seq(from = min(x, y), to = max(x,y), length = nbins[2]+1) index.x = cut(x, x.cuts, include.lowest = TRUE) index.y = cut(y, y.cuts, include.lowest = TRUE) m = matrix(0, nrow=nbins[1], ncol = nbins[2], dimnames = list( levels(index.x), levels(index.y) ) ) for ( i in 1:length(index.x) ) { m[index.x[i], index.y[i] ] = m[index.x[i], index.y[i] ] + 1 } xvals = x.cuts[1:nbins[1]] yvals = y.cuts[1:nbins[2]] # Return Value: list(x = xvals, y = yvals, z = m) } # ------------------------------------------------------------------------------ integrate2d = function(fun, error = 1.0e-5, ...) { # A function implemented by Diethelm Wuertz # Description: # 2-dimension quadrature rule on [0,1]^2 # Arguments: # fun - function to be integrated. The first argument requests # the x values, the second the y values, and the remaining # are reserved for additional parameters. # ... - parameters passed to the function to be integrated # Details: # see: Abramowitz and Stegun, p. 892 # FUNCTION: # Estimate a reasonable number of subintervals: H = sqrt(sqrt(error)) n = ceiling(1/H + 1) blocks = ceiling(log(n+1)/log(2)) n = 2^blocks-1 h = 1/(n-1) # The error will be of order h^4: error = h^4 # Create all grid coordinates: x = y = h*seq(1, n-1, by = 2) nx = ny = length(x) xoy = cbind(rep(x, ny), as.vector(matrix(y, nx, ny, byrow = TRUE))) XY = matrix(xoy, nx * ny, 2, byrow = FALSE) # The integration rule: rule = function(x, h, ...) { X = x[1] + h*c( 0, -1, -1, 1, 1, -1, 1, 0, 0) Y = x[2] + h*c( 0, -1, 1, -1, 1, 0, 0, -1, 1) W = c( 16, 1, 1, 1, 1, 4, 4, 4, 4)/36 ans = sum( W * fun(X, Y, ...) ) } # Result: ans = (4*h^2)*sum(apply(XY, 1, rule, h = h, ...)) # Return Value: list(value = ans, error = error, points = n) } ################################################################################ fCopulae/inst/obsolete/R/bv-dcauchy.R0000644000176000001440000000705412406047540017212 0ustar ripleyusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA # Copyrights (C) # for this R-port: # 1999 - 2007, Diethelm Wuertz, GPL # Diethelm Wuertz # info@rmetrics.org # www.rmetrics.org # for the code accessed (or partly included) from other R-ports: # see R's copyright and license files # for the code accessed (or partly included) from contributed R-ports # and other sources # see Rmetrics's copyright file ################################################################################ # FUNCTION: BIVARIATE CAUCHY DISTRIBUTION: # pcauchy2d Computes bivariate Cauchy probability function # dcauchy2d Computes bivariate Cauchy density function # rcauchy2d Generates bivariate Cauchy random deviates ################################################################################ pcauchy2d = function(x, y = x, rho = 0) { # A function Implemented by Diethelm Wuertz # Description: # Computes bivariate Cauchy probability function # Arguments: # x, y - two numeric values or vectors of the same length at # which the probability will be computed. # Example: # pt2d(rnorm(5), rnorm(5), 0.5, 5) # Value: # returns a numeric vector of probabilities of the same length # as the input vectors # FUNCTION: # Settings: # Probaility: ans = pt2d(x = x, y = y, rho = rho, nu = 1) attr(ans, "control") = c(rho = rho) # Return Value: ans } # ------------------------------------------------------------------------------ dcauchy2d = function(x, y = x, rho = 0) { # A function implemented by Diethelm Wuertz # Arguments: # n - number of random deviates to be generated # rho - the linear correlation, a numeric value between # minus one and one. # Description: # Computes bivariate Cauchy density function # Note: # Partly copied from contributed R package 'sn' # FUNCTION: # Density: density = dt2d(x = x, y = y, rho = rho, nu = 1) attr(density, "control") = c(rho = rho) # Return value: density } # ------------------------------------------------------------------------------ rcauchy2d = function(n, rho = 0) { # A function implemented by Diethelm Wuertz # Description: # Generates bivariate Cauchy random deviates # Arguments: # n - number of random deviates to be generated # rho - the linear correlation, a numeric value between # minus one and one. # Note: # Partly copied from contributed R package 'mvtnorm' # Author Friedrich Leisch # FUNCTION: # Random Deviates: ans = rt2d(n = n, rho = rho) attr(ans, "control") = c(rho = rho) # Return Value: ans } ################################################################################ fCopulae/inst/obsolete/R/mv-dst.R0000644000176000001440000001077212406047540016400 0ustar ripleyusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA # Copyrights (C) # for this R-port: # 1999 - 2007, Diethelm Wuertz, GPL # Diethelm Wuertz # info@rmetrics.org # www.rmetrics.org # for the code accessed (or partly included) from other R-ports: # see R's copyright and license files # for the code accessed (or partly included) from contributed R-ports # and other sources # see Rmetrics's copyright file ################################################################################ # FUNCTION: DESCRIPTION: # dmvst Multivariate Skew Sudent-t Density Function # pmvst Multivariate Skew Sudent-t Probability Function # rmvst Multivariate Skew Sudent-t Random Deviates # REQUIREMENTS: DESCRIPTION: # "mvtnorm" Contributed R - Package # "sn" | "mnormt" Contributed R - Package ################################################################################ ################################################################################ dmvst = function(x, dim = 2, mu = rep(0, dim), Omega = diag(dim), alpha = rep(0, dim), df = 4) { # A function implemented by Diethelm Wuertz # Description: # Multivariate Skew Sudent-t Density Function # Arguments: # FUNCTION: # Settings: xi = mu ans = NA # Univariate Case: if (is.vector(x) & dim == 1) { ans = dst(x, location = xi[1], scale = as.vector(Omega)[1], shape = alpha[1], df = Inf) } # Multivariate Case: if (is.matrix(x)) { if (dim == ncol(x)) { ans = dmst(x = x, xi = xi, Omega = Omega, alpha = alpha, df = df) } } # Check for conflicting Dimensions: if (is.na(ans[1])) { stop("conflicting x and dim") } # Return Value: as.vector(ans) } # ------------------------------------------------------------------------------ pmvst = function(q, dim = 2, mu = rep(0, dim), Omega = diag(dim), alpha = rep(0, dim), df = 4) { # A function implemented by Diethelm Wuertz # Description: # Multivariate Skew Sudent-t Probability Function # Arguments: # FUNCTION: # Settings: x = q xi = mu ans = NA # Univariate Case: if (is.vector(x) & dim == 1) { ans = pst(x, location = xi[1], scale = as.vector(Omega)[1], shape = alpha[1], df = df) } # Multivariate Case: if (is.matrix(x)) { if (dim == ncol(x)) { ans = NULL for (i in 1:nrow(x) ) { ans = c(ans, pmst(x = x[i,], xi = xi, Omega = Omega, alpha = alpha, df = df)) } } } # Check for conflicting Dimensions: if (is.na(ans[1])) { stop("conflicting x and dim") } # Return Value: as.vector(ans) } # ------------------------------------------------------------------------------ rmvst = function(n, dim = 2, mu = rep(0, dim), Omega = diag(dim), alpha = rep(0, dim), df = 4) { # A function implemented by Diethelm Wuertz # Description: # Multivariate Skew Sudent-t Random Number Generator # Arguments: # FUNCTION: # Settings: ans = NA xi = mu # Univariate Case: if (dim == 1) { ans = as.matrix(rst(n, location = xi[1], scale = as.vector(Omega)[1], shape = alpha[1], df = df)) } # Multivariate Case: if (dim > 1) { ans = rmst(n, xi = xi, Omega = Omega, alpha = alpha, df = df) } # Check for conflicting Dimensions: if (is.na(ans[1])) { stop("dim must be greater 1") } # Return Value: rownames(ans) = as.character(1:n) colnames(ans) = as.character(1:dim) ans } ################################################################################ fCopulae/inst/obsolete/R/mv-dsnorm.R0000644000176000001440000001121612406047540017102 0ustar ripleyusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA # Copyrights (C) # for this R-port: # 1999 - 2007, Diethelm Wuertz, GPL # Diethelm Wuertz # info@rmetrics.org # www.rmetrics.org # for the code accessed (or partly included) from other R-ports: # see R's copyright and license files # for the code accessed (or partly included) from contributed R-ports # and other sources # see Rmetrics's copyright file ################################################################################ # FUNCTION: DESCRIPTION: # dmvsnorm Multivariate Skew Normal Density Function # pmvsnorm Multivariate Skew Normal Probability Function # rmvsnorm Multivariate Skew Normal Random Deviates # REQUIREMENTS: DESCRIPTION: # "mvtnorm" Contributed R - Package # "sn" | "mnormt" Contributed R - Package ################################################################################ ################################################################################ # Multivariate Skew Normal Distribution dmvsnorm = function(x, dim = 2, mu = rep(0, dim), Omega = diag(dim), alpha = rep(0, dim)) { # A function implemented by Diethelm Wuertz # Description: # Multivariate Skew Normal Density Function # Note: # Requires dsn() and dmsn() from R package sn # FUNCTION: # Settings: xi = mu ans = NA # Univariate Case: if (is.vector(x) & dim == 1) { ans = dsn(x, location = xi[1], scale = as.vector(Omega)[1], shape = alpha[1]) } # Multivariate Case: if (is.matrix(x)) { if (dim == ncol(x)) { ans = dmsn(x = x, xi = xi, Omega = Omega, alpha = alpha) } } # Check for conflicting Dimensions: if (is.na(ans[1])) { stop("conflicting x and dim") } # Return Value: as.vector(ans) } # ------------------------------------------------------------------------------ pmvsnorm = function(q, dim = 2, mu = rep(0, dim), Omega = diag(dim), alpha = rep(0, dim)) { # A function implemented by Diethelm Wuertz # Description: # Multivariate Skew Normal Probability Function # Algorithm: # Note: # Requires psn() and pmsn() from R package sn # FUNCTION: # Settings: x = q xi = mu ans = NA # Univariate Case: if (is.vector(x) & dim == 1) { ans = psn(x, location = xi[1], scale = as.vector(Omega)[1], shape = alpha[1]) } # Multivariate Case: if (is.matrix(x)) { if (dim == ncol(x)) { ans = NULL for (i in 1:nrow(x) ) { ans = c(ans, pmsn(x = x[i,], xi = xi, Omega = Omega, alpha = alpha)) } } } # Check for conflicting Dimensions: if (is.na(ans[1])) { stop("conflicting x and dim") } # Return Value: as.vector(ans) } # ------------------------------------------------------------------------------ rmvsnorm = function(n, dim = 2, mu = rep(0, dim), Omega = diag(dim), alpha = rep(0, dim)) { # A function implemented by Diethelm Wuertz # Description: # Multivariate Skew Normal Random Number Generator # Algorithm: # Note: # Requires rsn() and rmsn() from R package sn # FUNCTION: # Settings: ans = NA xi = mu # Univariate Case: if (dim == 1) { ans = as.matrix(rsn(n, location = xi[1], scale = as.vector(Omega)[1], shape = alpha[1])) } # Multivariate Case: if (dim > 1) { ans = rmsn(n, xi = xi, Omega = Omega, alpha = alpha) } # Check for conflicting Dimensions: if (is.na(ans[1])) { stop("dim must be greater 1") } # Return Value: rownames(ans) = as.character(1:n) colnames(ans) = as.character(1:dim) ans } ################################################################################ fCopulae/inst/obsolete/R/biv-binning.R0000644000176000001440000002443312406047540017367 0ustar ripleyusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU Library General Public License for more details. # # You should have received A copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA # Copyrights (C) # for this R-port: # 1999 - 2007, Diethelm Wuertz, GPL # Diethelm Wuertz # info@rmetrics.org # www.rmetrics.org # for the code accessed (or partly included) from other R-ports: # see R's copyright and license files # for the code accessed (or partly included) from contributed R-ports # and other sources # see Rmetrics's copyright file ################################################################################ # FUNCTION: DESCRIPTION: # squareBinning Square binning of irregularly spaced points # plot S3 Method for plotting square binned points # FUNCTION: DESCRIPTION: # hexBinning Hexagonal binning of irregularly spaced points # plot S3 Method for plotting hexagonal binned points ################################################################################ ################################################################################ # FUNCTION: DESCRIPTION: # squareBinning Square binning of irregularly spaced points # plot S3 Method for plotting square binned points squareBinning = function(x, y = NULL, bins = 30) { # A function implemented by Diethelm Wuertz # Description: # Returns 2D Histogram Counts # Arguments: # x, y - two vectors of coordinates of data. If y is NULL then x # is assumed to be a two column matrix, where the first column # contains the x data, and the second column the y data. # 'timeSeries' objects are also allowed as input. # bins - number of bins in each dimension, may be a scalar or a 2 # element vector. The default value is 20. # Value: # A list with three elements x, y, and z. x and y are vectors # spanning the two dimensioanl grid and z the corresponding # matrix. The output can directly serve as input to the # plotting functions image, contour and persp. # Example: # sB = squareBinning(x = rnorm(1000), y = rnorm(1000)); plot(sB) # Note: # Partly copied from R Package gregmisc, function 'hist2d'. # FUNCTION: # 2D Histogram Counts: if (is.null(y)) { x = as.matrix(x) y = x[, 2] x = x[, 1] } else { x = as.vector(x) y = as.vector(y) } data = cbind(x, y) # Bins: n = bins if (length(n) == 1) { nbins = c(n, n) } else { nbins = n } # Binning: xo = seq(min(x), max(x), length = nbins[1]) yo = seq(min(y), max(y), length = nbins[2]) xvals = xo[-1] - diff(xo)/2 yvals = yo[-1] - diff(yo)/2 ix = findInterval(x, xo) iy = findInterval(y, yo) xcm = ycm = zvals = matrix(0, nrow = nbins[1], ncol = nbins[2]) for (i in 1:length(x)) { zvals[ix[i], iy[i]] = zvals[ix[i], iy[i]] + 1 xcm[ix[i], iy[i]] = xcm[ix[i], iy[i]] + x[i] ycm[ix[i], iy[i]] = ycm[ix[i], iy[i]] + y[i] } # Reduce to non-empty cells: u = v = w = ucm = vcm = rep(0, times = nbins[1]*nbins[2]) L = 0 for (i in 1:(nbins[1]-1)) { for (j in 1:(nbins[2]-1)) { if (zvals[i, j] > 0) { L = L + 1 u[L] = xvals[i] v[L] = yvals[j] w[L] = zvals[i, j] ucm[L] = xcm[i, j]/w[L] vcm[L] = ycm[i, j]/w[L] } } } length(u) = length(v) = length(w) = L length(ucm) = length(vcm) = L ans = list(x = u, y = v, z = w, xcm = ucm, ycm = vcm, bins = bins, data = data) class(ans) = "squareBinning" # Return Value: ans } # ------------------------------------------------------------------------------ plot.squareBinning = function(x, col = heat.colors(12), addPoints = TRUE, addRug = TRUE, ...) { # A function implemented by Diethelm Wuertz # Description: # Plot square binned data points # FUNCTION: # Binning: X = x$x Y = x$y # Plot Center Points: plot(X, Y, type = "n", ...) # Create Hexagon Coordinates: rx = min(diff(unique(sort(X))))/2 ry = min(diff(unique(sort(Y))))/2 u = c(-rx, rx, rx, -rx) v = c( ry, ry, -ry, -ry) # Create Color Palette: N = length(col) Z = x$z zMin = min(Z) zMax = max(Z) Z = (Z - zMin)/(zMax - zMin) Z = trunc(Z*(N-1)+1) # Add Colored Hexagon Polygons: for (i in 1:length(X)) { polygon(u+X[i], v+Y[i], col = col[Z[i]], border = "white") } # Add Center of Mass Points: if (addPoints) { points(x$xcm, x$ycm, pch = 19, cex = 1/3, col = "black") } # Add rug: if (addRug) { rug(x$data[, 1], ticksize = 0.01, side = 3) rug(x$data[, 2], ticksize = 0.01, side = 4) } # Return Value: invisible(NULL) } ################################################################################ # FUNCTION: DESCRIPTION: # hexBinning Hexagonal binning of irregularly spaced points # plot S3 Method for plotting hexagonal binned points hexBinning = function(x, y = NULL, bins = 30) { # A function implemented by Diethelm Wuertz # Description: # Does a hexagonal binning of data points # Arguments: # x, y - two vectors of coordinates of data. If y is NULL then x # is assumed to be a two column matrix, where the first column # contains the x data, and the second column the y data. # 'timeSeries' objects are also allowed as input. # bins - number of bins in each dimension, may be a scalar or a 2 # element vector. The default value is 20. # Example: # hB = hexBinning(x = rnorm(10000), y = rnorm(10000)); plot(hB) # FUNCTION: # Extract Series: if (is.null(y)) { x = as.matrix(x) y = x[, 2] x = x[, 1] } else { x = as.vector(x) y = as.vector(y) } data = cbind(x, y) # Set Parameters: shape = 1 n = length(x) xbnds = range(x) ybnds = range(y) jmax = floor(bins + 1.5001) c1 = 2 * floor((bins *shape)/sqrt(3) + 1.5001) imax = trunc((jmax*c1 -1)/jmax + 1) lmax = jmax * imax cell = cnt = xcm = ycm = rep(0, times = max(n, lmax)) xmin = xbnds[1] ymin = ybnds[1] xr = xbnds[2] - xmin yr = ybnds[2] - ymin c1 = bins/xr c2 = bins*shape/(yr*sqrt(3.0)) jinc = jmax lat = jinc + 1 iinc = 2*jinc con1 = 0.25 con2 = 1.0/3.0 # Count Bins: for ( i in 1:n ) { sx = c1 * (x[i] - xmin) sy = c2 * (y[i] - ymin) j1 = floor(sx + 0.5) i1 = floor(sy + 0.5) dist1 = (sx-j1)^2 + 3.0*(sy-i1)^2 if( dist1 < con1) { L = i1*iinc + j1 + 1 } else if (dist1 > con2) { L = floor(sy)*iinc + floor(sx) + lat } else { j2 = floor(sx) i2 = floor(sy) test = (sx-j2 -0.5)^2 + 3.0*(sy-i2-0.5)^2 if ( dist1 <= test ) { L = i1*iinc + j1 + 1 } else { L = i2*iinc + j2 + lat } } cnt[L] = cnt[L]+1 xcm[L] = xcm[L] + (x[i] - xcm[L])/cnt[L] ycm[L] = ycm[L] + (y[i] - ycm[L])/cnt[L] } # Reduce to Non-Empty Cells: nc = 0 for ( L in 1:lmax ) { if(cnt[L] > 0) { nc = nc + 1 cell[nc] = L cnt[nc] = cnt[L] xcm[nc] = xcm[L] ycm[nc] = ycm[L] } } bnd = c(imax, jmax) bnd[1] = (cell[nc]-1)/bnd[2] + 1 length(cell) = nc length(cnt) = nc length(xcm) = nc length(ycm) = nc if(sum(cnt) != n) warning("Lost counts in binning") # Compute Positions: c3 = diff(xbnds)/bins ybnds = ybnds c4 = (diff(ybnds) * sqrt(3))/(2 * shape * bins) cell = cell - 1 i = cell %/% jmax j = cell %% jmax y = c4 * i + ybnds[1] x = c3 * ifelse(i %% 2 == 0, j, j + 0.5) + xbnds[1] # Result: ans = list(x = x, y = y, z = cnt, xcm = xcm, ycm = ycm, bins = bins, data = data) class(ans) = "hexBinning" # Return Value: ans } # ------------------------------------------------------------------------------ plot.hexBinning = function(x, col = heat.colors(12), addPoints = TRUE, addRug = TRUE, ...) { # A function implemented by Diethelm Wuertz # Description: # Plot hexagonal binned data points # Example: # hexPlot(rnorm(1000), rnorm(1000), bins = 20) # FUNCTION: # Binning: X = x$x Y = x$y # Plot Center Points: plot(X, Y, type = "n", ...) # Create Hexagon Coordinates: rx = min(diff(unique(sort(X)))) ry = min(diff(unique(sort(Y)))) rt = 2*ry u = c(rx, 0, -rx, -rx, 0, rx) v = c(ry, rt, ry, -ry, -rt, -ry) / 3 # Create Color Palette: N = length(col) z = x$z zMin = min(z) zMax = max(z) Z = (z - zMin)/(zMax - zMin) Z = trunc(Z*(N-1)+1) # Add Colored Hexagon Polygons: for (i in 1:length(X)) { polygon(u+X[i], v+Y[i], col = col[Z[i]], border = "white") } # Add Center of Mass Points: if (addPoints) { points(x$xcm, x$ycm, pch = 19, cex = 1/3, col = "black") } # Add rug: if (addRug) { rug(x$data[, 1], ticksize = 0.01, side = 3) rug(x$data[, 2], ticksize = 0.01, side = 4) } # Return Value: invisible(NULL) } ################################################################################ fCopulae/inst/obsolete/R/bv-delliptical.R0000644000176000001440000002326112406047540020056 0ustar ripleyusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA # Copyrights (C) # for this R-port: # 1999 - 2007, Diethelm Wuertz, GPL # Diethelm Wuertz # info@rmetrics.org # www.rmetrics.org # for the code accessed (or partly included) from other R-ports: # see R's copyright and license files # for the code accessed (or partly included) from contributed R-ports # and other sources # see Rmetrics's copyright file ################################################################################ # FUNCTION: ELLIPTICAL BIVARIATE DISTRIBUTIONS: # delliptical2d Computes density for elliptical distributions # .gfunc2d Generator Function for elliptical distributions # .delliptical2dSlider Slider for bivariate densities ################################################################################ delliptical2d = function(x, y = x, rho = 0, param = NULL, type = c("norm", "cauchy", "t", "logistic", "laplace", "kotz", "epower"), output = c("vector", "list")) { # A function implemented by Diethelm Wuertz # Description: # Density function for bivariate elliptical distributions # Arguments: # x, y - two numeric vectors of the same length. # rho - a anumeric value specifying the correlation. # param - NULL, a numeric value, or a numeric vector adding # additional parameters to the generator function. # type - a character string denoting the type of distribution. # This may be either # "norm" for the normal distribution, or # "cauchy" for the Cauchy distribution, or # "t" for the Student-t distribution, or # "logistic" for the logistic distribution, or # "laplace" for the distribution, or # "kotz" for the original Kotz distribution, or # "epower" for the exponential power distribution # FUNCTION: # Type: type = type[1] # Settings: if (is.list(x)) { y = x$y x = x$x } if (is.matrix(x)) { y = x[, 2] x = x[, 2] } # Add Default Parameters: if (is.null(param)) { if (type == "t") param = c(nu = 4) if (type == "kotz") param = c(r = sqrt(2)) if (type == "epower") param = c(r = sqrt(2), s = 1/2) } # Density: xoy = ( x^2 - 2*rho*x*y + y^2 ) / (1-rho^2) lambda = .gfunc2d(param = param, type = type)[[1]] density = lambda * .gfunc2d(x = xoy, param = param, type = type) / sqrt(1 - rho^2) # Add attributes: if (is.null(param)) { attr(density, "control") = unlist(list(type = type, rho = rho)) } else { attr(density, "control") = unlist(list(type = type, rho = rho, param = param)) } # As List ? if (output[1] == "list") { N = sqrt(length(x)) x = x[1:N] y = matrix(y, ncol = N)[1, ] density = list(x = x, y = y, z = matrix(density, ncol = N)) } # Return Value: density } # ------------------------------------------------------------------------------ .gfunc2d = function(x, param = NULL, type = c("norm", "cauchy", "t", "logistic", "laplace", "kotz", "epower")) { # A function implemented by Diethelm Wuertz # Description: # Generator function for elliptical distributions # Note: # A copy from fExtremes 'gfunc' # Arguments: # x - a numeric vector # param - NULL, a numeric value, or a numeric vector adding. # additional parameters to the generator function. # type - a character string denoting the type of distribution. # This may be either # "norm" for the normal distribution, or # "cauchy" for the Cauchy distribution, or # "t" for the Student-t distribution, or # "logistic" for the logistic distribution, or # "laplace" for the distribution, or # "kotz" for the original Kotz distribution, or # "epower" for the exponential power distribution # Value: # Returns a numeric vector "g(x)" for the generator computed at # the x values taken from the input vector. If x is missing, # the normalizing constant "lambda" will be returned. # FUNCTION: # Handle Missing x: if (missing(x)) { x = NA output = "lambda" } else { output = "g" } # Get Type: type = type[1] # Get Parameters: # if (is.null(param)) param = .ellipticalParam$param # Create Generator: if (type == "norm") { g = exp(-x/2) lambda = 1 / (2*pi) param = NULL } if (type == "cauchy") { g = ( 1 + x )^ (-3/2 ) lambda = 1 / (2*pi) param = NULL } if (type == "t") { if (is.null(param)) { nu = 4 } else { nu = param[[1]] } g = ( 1 + x/nu )^ ( -(nu+2)/2 ) lambda = 1/(2*pi) param = c(nu = nu) } if (type == "logistic"){ g = exp(-x/2)/(1+exp(-x/2))^2 # lambda: # integrate(function(x) { exp(-x)/(1+exp(-x))^2}, 0, Inf, # subdivision = 10000, rel.tol = .Machine$double.eps^0.8) # 0.5 with absolute error < 2.0e-13 lambda = 1 / pi param = NULL } if (type == "laplace") { # or "double exponential" # epower: r = sqrt(2) s = 1/2 g = exp(-r*(x/2)^s) lambda = s * r^(1/s) / ( 2 * pi * gamma(1/s) ) param = NULL } if (type == "kotz") { # epower: s = 1 if (is.null(param)) { r = sqrt(2) } else { r = param } g = exp(-r*(x/2)) lambda = r/(2*pi) param = c(r = r) } if (type == "epower") { if (is.null(param)) { r = sqrt(2) s = 1/2 } else { r = param[[1]] s = param[[2]] } g = exp(-r*(x/2)^s) lambda = s * r^(1/s) / ( 2 * pi * gamma(1/s) ) param = c(r = r, s = s) } # Output: output = output[1] if (output == "g") { ans = g } else if (output == "lambda") { ans = lambda } # Add Control: if (output == "g") { attr(ans, "control") = c(type = type, lambda = as.character(lambda)) } else if (output == "lambda") { if (is.null(param)) { attr(ans, "control") = unlist(list(type = type)) } else { attr(ans, "control") = unlist(list(type = type, param = param)) } } # Return Value: ans } # ------------------------------------------------------------------------------ .delliptical2dSlider = function(B = 10, eps = 1.e-3) { # A function implemented by Diethelm Wuertz # Description: # Displays interactively perspective plots of density #FUNCTION: # Graphic Frame: par(mfrow = c(1, 1), cex = 0.7) # Internal Function: refresh.code = function(...) { # Sliders: Distribution = .sliderMenu(no = 1) N = .sliderMenu(no = 2) rho = .sliderMenu(no = 3) nu = .sliderMenu(no = 4) r = .sliderMenu(no = 5) s = .sliderMenu(no = 6) nlev = .sliderMenu(no = 7) ncol = .sliderMenu(no = 8) if (rho == +1) rho = rho - eps if (rho == -1) rho = rho + eps # Title: Names = c("- Normal", "- Cauchy", "- Student t", "- Logistic", "- Laplace", "- Kotz", "- Exponential Power") Title = paste("Elliptical Density No:", as.character(Distribution), Names[Distribution], "\nrho = ", as.character(rho)) if (Distribution == 3) Title = paste(Title, "nu =", as.character(nu)) if (Distribution >= 6) Title = paste(Title, "r =", as.character(r)) if (Distribution >= 7) Title = paste(Title, "s =", as.character(s)) # Plot: xy= grid2d(x = seq(-5, 5, length = N)) Type = c("norm", "cauchy", "t", "logistic", "laplace", "kotz", "epower") param = NULL if (Distribution == 3) param = nu if (Distribution == 6) param = r if (Distribution == 7) param = c(r, s) D = delliptical2d(x = xy, rho = rho, param = param, type = Type[Distribution], output = "list") image(D, col = heat.colors(ncol), xlab = "x", ylab = "y" ) contour(D, nlevels = nlev, add = TRUE) title(main = Title) # Reset Frame: par(mfrow = c(1, 1), cex = 0.7) } # Open Slider Menu: plot.names = c("Plot - levels", "... colors") .sliderMenu(refresh.code, names = c("Distribution", "N", "rho", "t: nu", "r", "s", plot.names), minima = c( 1, 10, -1, 1, 0, 0, 10, 12), maxima = c( 7, 100, +1, B, B, B, 100, 256), resolutions = c( 1, 10, 0.1, 0.1, 0.1, 0.1, 10, 1), starts = c( 1, 10, 0, 4, 1, 1, 10, 12)) } ################################################################################ fCopulae/inst/obsolete/R/bv-dnorm.R0000644000176000001440000002170412406047540016707 0ustar ripleyusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA # Copyrights (C) # for this R-port: # 1999 - 2007, Diethelm Wuertz, GPL # Diethelm Wuertz # info@rmetrics.org # www.rmetrics.org # for the code accessed (or partly included) from other R-ports: # see R's copyright and license files # for the code accessed (or partly included) from contributed R-ports # and other sources # see Rmetrics's copyright file ################################################################################ # FUNCTION: BIVARIATE NORMAL DISTRIBUTION: # pnorm2d Computes bivariate Normal probability function # dnorm2d Computes bivariate Normal density function # rnorm2d Generates bivariate normal random deviates ################################################################################ pnorm2d = function(x, y = x, rho = 0) { # pnorm2d: A copy from R package "sn" # Description: # Computes bivariate Normal probability function # Arguments: # x, y - two numeric values or vectors of the same length at # which the probability will be computed. # Value: # returns a numeric vector of probabilities of the same length # as the input vectors # FUNCTION: # Probaility: X = cbind(x, y) ans = apply(X, 1, .pnorm2d, rho = rho) attr(ans, "control") = c(rho = rho) # Return Value: ans } # ------------------------------------------------------------------------------ .pnorm2d = function(X, rho = 0) { # pnorm2d: A copy from R package "sn" # Description: # Bivariate Normal probability function # Arguments: # x, y - two numeric values at which the probability will # be computed. # Value: # returns a numeric vector of probabilities of the same length # as the input vectors # FUNCTION: # Probability: x = X[1] y = X[2] if (x == 0 & y == 0) { return(0.25 + asin(rho)/(2 * pi)) } p = 0.5 * (pnorm(x) + pnorm(y)) if (x == 0) { p = p - 0.25 * sign(y) } else { if (is.finite(x)) { Y = (y - rho * x)/(x * sqrt(1 - rho^2)) } else { Y = -rho/sqrt(1-rho^2) } p = p - .TOwen(x, Y) } if (y == 0) { p = p - 0.25 * sign(x) } else { if (is.finite(y)) { X = (x - rho * y)/(y * sqrt(1 - rho^2)) } else { X = -rho/sqrt(1-rho^2) } p = p - .TOwen(y, X) } if (is.finite(x) & is.finite(y)) { if ((x * y < 0) | ((x * y == 0) & (x + y) < 0)) { p = p - 0.5 } } # Return Value: return(p) } # ------------------------------------------------------------------------------ .TInt = function(h, a, jmax, cut.point) { # T.int: A copy from R package "sn" # Note: # Required by .pnorm2d and .TOwen # FUNCTION: .fui = function(h, i) (h^(2 * i))/((2^i) * gamma(i + 1)) seriesL = seriesH = NULL i = 0:jmax low = (h <= cut.point) hL = h[low] hH = h[!low] L = length(hL) if (L > 0) { b = outer(hL, i, .fui) cumb = apply(b, 1, cumsum) b1 = exp(-0.5 * hL^2) * t(cumb) matr = matrix(1, jmax + 1, L) - t(b1) jk = rep(c(1, -1), jmax)[1:(jmax + 1)]/(2 * i + 1) matr = t(matr * jk) %*% a^(2 * i + 1) seriesL = (atan(a) - as.vector(matr))/(2 * pi) } if (length(hH) > 0) { seriesH = atan(a) * exp(-0.5 * (hH^2) * a/atan(a)) * (1 + 0.00868 * (hH^4) * a^4)/(2 * pi) } series = c(seriesL, seriesH) id = c((1:length(h))[low], (1:length(h))[!low]) series[id] = series # Return Value: series } # ------------------------------------------------------------------------------ .TOwen = function (h, a, jmax = 50, cut.point = 6) { # T.Owen: A copy from R package "sn" # Note: # Required by .pnorm2d # FUNCTION: if (!is.vector(a) | length(a) > 1) stop("a must be a vector of length 1") if (!is.vector(h)) stop("h must be a vector") aa = abs(a) ah = abs(h) if (aa == Inf) return(0.5 * pnorm(-ah)) if (aa == 0) return(rep(0, length(h))) na = is.na(h) inf = (ah == Inf) ah = replace(ah, (na | inf), 0) if (aa <= 1) { owen = .TInt(ah, aa, jmax, cut.point) } else { owen = 0.5 * pnorm(ah) + pnorm(aa * ah) * (0.5 - pnorm(ah)) - .TInt(aa * ah, (1/aa), jmax, cut.point) } owen = replace(owen, na, NA) owen = replace(owen, inf, 0) ans = return(owen * sign(a)) # Return Value: ans } # ------------------------------------------------------------------------------ dnorm2d = function(x, y = x, rho = 0) { # A function implemented by Diethelm Wuertz # Arguments: # x,y - two numeric vectors # rho - the linear correlation, a numeric value between # minus one and one. # FUNCTION: # Argument: xoy = (x^2 - 2*rho*x*y + y^2)/ (2*(1 - rho^2)) # Density: density = exp(-xoy) / ( 2*pi*sqrt(1-rho^2)) attr(density, "control") = c(rho = rho) # Return Value: density } # ------------------------------------------------------------------------------ .dnorm2d = function(x, y = x, rho = 0) { # A function implemented by Diethelm Wuertz # Arguments: # x,y - two numeric vectors # rho - the linear correlation, a numeric value between # minus one and one. # Note: # Partly copied from contributed R package 'mvtnorm' # Author Friedrich Leisch # FUNCTION # Settings: mean = c(0,0) sigma = diag(2) sigma[1,2] = sigma[2,1] = rho log = FALSE x = cbind(x, y) # From mvtnorm - Check: if (is.vector(x)) { x = matrix(x, ncol = length(x)) } if (missing(mean)) { mean = rep(0, length = ncol(x)) } if (missing(sigma)) { sigma = diag(ncol(x)) } if (ncol(x) != ncol(sigma)) { stop("x and sigma have non-conforming size") } if (nrow(sigma) != ncol(sigma)) { stop("sigma meanst be a square matrix") } if (length(mean) != nrow(sigma)) { stop("mean and sigma have non-conforming size") } # From mvtnorm - Density: distval = mahalanobis(x, center = mean, cov = sigma) logdet = sum(log(eigen(sigma, symmetric = TRUE, only.values = TRUE)$values)) logretval = -(ncol(x)*log(2*pi) + logdet + distval)/2 if(log) return(logretval) ans = exp(logretval) attr(ans, "control") = c(rho = rho) # Return value: ans } # ------------------------------------------------------------------------------ rnorm2d = function(n, rho = 0) { # A function implemented by Diethelm Wuertz # Description: # Generates bivariate normal random deviates # Arguments: # n - number of random deviates to be generated # rho - the linear correlation, a numeric value between # minus one and one. # Note: # Partly copied from contributed R package 'mvtnorm' # Author Friedrich Leisch # FUNCTION # Settings: mean = c(0,0) sigma = diag(2) sigma[1,2] = sigma[2,1] = rho # From mvtnorm - Random Numbers: ev = eigen(sigma, symmetric = TRUE)$values if (!all(ev >= -sqrt(.Machine$double.eps) * abs(ev[1]))) warning("sigma is numerically not positive definite") sigsvd = svd(sigma) ans = t(sigsvd$v %*% (t(sigsvd$u) * sqrt(sigsvd$d))) ans = matrix(rnorm(n * ncol(sigma)), nrow = n) %*% ans ans = sweep(ans, 2, mean, "+") attr(ans, "control") = c(rho = rho) # Return Value: ans } # ------------------------------------------------------------------------------ .rnorm2d = function(n, rho = 0) { # A function implemented by Diethelm Wuertz # Description: # Alternative direct algorithm from Lindskog Master Thesis # Arguments: # n - number of random deviates to be generated # rho - the linear correlation, a numeric value between # minus one and one. # FUNCTION: # Random Deviates x = matrix(c(1, rho, rho,1), 2) V = NULL U = chol(x) siz = dim(x)[1] for(i in 1:n) { Z = rnorm(siz) res = t(U)%*%Z V = cbind(V,res) } rmn = t(V) # Return Value: rmn } ################################################################################ fCopulae/inst/obsolete/R/builtin-adapt.R0000644000176000001440000001335712406047540017725 0ustar ripleyusers # Title: adapt -- multidimensional numerical integration # Package: adapt # Version: 1.0-4 # Author: FORTRAN by Alan Genz, # S by Mike Meyer, R by Thomas Lumley and Martin Maechler # Description: Adaptive Quadrature in up to 20 dimensions # Depends: # License: Unclear (Fortran) -- code in Statlib's ./S/adapt # Maintainer: Thomas Lumley # Packaged: Fri Apr 20 11:38:07 2007; thomas # [from Statlib's original http://lib.stat.cmu.edu/S/adapt ] # This code contains an S function and supporting C and Fortran code for # adaptive quadrature. The underlyling fortran code is purported to # work in from 2 to 20 dimensions. The code is set up to dynamically # load from a central library area. If you can not do dynamic loading, # you may need to build a staticly loaded version. The adapt S function # calls load.if.needed to do the dynamic loading. You will have to # change the functions used here (probably to call library.dynam). # S code written by Michael Meyer (mikem@andrew.cmu.edu). # October, 1989. # 2002-03-14 Martin Maechler # * DESCRIPTION (Version): 1.0-3 --> CRAN # * R/adapt.R (adapt): use defaults for minpts, maxpts, eps; # more logical maxpts default (for ndim >= 7) using rulcls # * man/adapt.Rd: extended example # 2002-03-13 Martin Maechler # * DESCRIPTION (Version): 1.0-2 # * man/adapt.Rd: indentation, using \code{.}, etc; # example also tries p=5 dimensions # * R/adapt.R: clean up (spaces) # 2002-01-09 Martin Maechler # * R/adapt.R: do not use .Alias anymore # 2001-06-29 Thomas Lumley # * move (improved!) integrate() into base, using .Call() etc. # Message-ID: <4AD7A74B.3020108@math.wsu.edu> # Date: Thu, 15 Oct 2009 15:50:51 -0700 # From: Alan Genz # User-Agent: Mozilla/5.0 (X11; U; Linux i686; en-US; rv:1.8.1.21) # Gecko/20090402 SeaMonkey/1.1.16 # MIME-Version: 1.0 # To: Diethelm Wuertz # CC: Alan C Genz # Subject: Re: adapt # References: <4AD3032B.4090801@itp.phys.ethz.ch> # In-Reply-To: <4AD3032B.4090801@itp.phys.ethz.ch> # Content-Type: text/plain; charset=ISO-8859-1; format=flowed # Content-Transfer-Encoding: 7bit # Status: O # Dear Prof. Wuertz, # Thank you for your message and your interest in my adaptive integration # Fortran code. I would be pleased if you included my code in your open # source R fCopulae package under the Gnu GPL2 license. You have my # permission to do this. # Sincerely, # Alan Genz ################################################################################ adapt <- function (ndim, lower, upper, minpts = 100, maxpts = NULL, functn, eps = 0.01, ...) { keep.trying <- is.null(maxpts) if (ndim == 1) { ## fudge for 1-d functions warning("Using integrate() from base package for 1-d integration") if (keep.trying) maxpts <- minpts return(integrate(functn,lower,upper,subdivisions=maxpts,rel.tol=eps,...)) } ## else ndim >= 2 : ## Check to make sure that upper and lower are reasonable lengths ## Both the upper and lower limits should be at least of length ndim if (length(lower) < ndim || length(upper) < ndim)#MM: dropped 'at least': stop(paste("The lower and upper vectors need to have ndim elements\n", "Your parameters are: ndim", ndim, ", length(lower)", length(lower), ", length(upper)", length(upper), "\n")) ff <- if(length(list(...)) && length(formals(functn)) > 1) function(x) functn(x, ...) else functn # .Alias rulcls <- 2^ndim + 2*ndim^2 + 6*ndim + 1 #-> ../src/adapt.f ## maxpts should be large enough. Prefer 10*rulclc, but use 2*rulclc. if (keep.trying) maxpts <- max(minpts, 500, 2 * rulcls) else { if (minpts >= maxpts) { warning(paste("maxpts must be > minpts.\n", "Maxpts has be increased to minpts + 1")) maxpts <- minpts + 1 } ## if (maxpts < 2 * rulcls) { warning(paste( "You have maxpts (= ", maxpts, ") too small\n", "It needs to be at least 2 times 2^ndim + 2*ndim^2 + 6*ndim+1\n", "It has been reset to ", 2 * rulcls, "\n", sep="")) maxpts <- 2 * rulcls } } repeat { lenwrk <- (2*ndim + 3)* (1 + maxpts/rulcls)/2# mandated in adapt source x <- .C("cadapt", as.integer(ndim), as.double(lower), as.double(upper), minpts = as.integer(minpts), maxpts = as.integer(maxpts), ## now pass ff and current environment ff, rho = environment(), as.double(eps), relerr = double(1), lenwrk = as.integer(lenwrk), value = double(1), # will contain the value of the integral ifail = integer(1), PACKAGE = "fCopulae")[ c("value", "relerr", "minpts", "lenwrk", "ifail")] if (x$ifail == 1 && keep.trying) maxpts <- maxpts*2 else break } if(x$ifail) warning(x$warn <- c("Ifail=1, maxpts was too small. Check the returned relerr!", paste("Ifail=2, lenwrk was too small. -- fix adapt() !\n", "Check the returned relerr!"), "Ifail=3: ndim > 20 -- rewrite the fortran code ;-) !", "Ifail=4, minpts > maxpts; should not happen!", "Ifail=5, internal non-convergence; should not happen!" )[x$ifail]) class(x) <- "integration" x } # ------------------------------------------------------------------------------ print.integration <- function(x, ...) { print(noquote(sapply(x, format, ...)),...) invisible(x) } ################################################################################ fCopulae/inst/obsolete/R/biv-gridding.R0000644000176000001440000000774312406047540017537 0ustar ripleyusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU Library General Public License for more details. # # You should have received A copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA # Copyrights (C) # for this R-port: # 1999 - 2007, Diethelm Wuertz, GPL # Diethelm Wuertz # info@rmetrics.org # www.rmetrics.org # for the code accessed (or partly included) from other R-ports: # see R's copyright and license files # for the code accessed (or partly included) from contributed R-ports # and other sources # see Rmetrics's copyright file # fEcofin::4A-BivariateGridding.R ################################################################################ # FUNCTION: GRID DATA: # gridData Generates grid data set # persp.gridData Generates perspective plot from a grid data object # contour.gridData Generates contour plot from a grid data object ################################################################################ ################################################################################ # FUNCTION: GRID DATA: # gridData Generates grid data set # persp.gridData Generates perspective plot from a grid data object # contour.gridData Generates contour plot from a grid data object gridData = function(x = (-10:10)/10, y = x, z = outer(x, y, function(x, y) (x^2+y^2)) ) { # A function implemented by Diethelm Wuertz # Description: # Generates a grid data set # Arguments: # x, y - two numeric vectors of grid pounts # z - a numeric matrix or any other rectangular object which can # be transformed by the function 'as.matrix' into a matrix # object. # Example: # persp(as.gridData()) # FUNCTION: # Grid Data: data = list(x = x, y = y, z = as.matrix(z)) class(data) = "gridData" # Return Value: data } # ------------------------------------------------------------------------------ persp.gridData = function(x, theta = -40, phi = 30, col = "steelblue", ticktype = "detailed", ...) { # A function implemented by Diethelm Wuertz # Description: # S3 method to generate a perspective plot from a grid data object # Example: # x = y = seq(-10, 10, length = 30) # z = outer(x, y, function(x, y) { r <- sqrt(x^2+y^2); 10 * sin(r)/r }) # data = list(x = x, y = y, z = z) # class(data) = "gridData" # persp(data) # FUNCTION: # Grid Data: class(x) = "default" persp(x, theta = theta, phi = phi, col = col, ticktype = ticktype, ...) # Return Value: invisible(NULL) } # ------------------------------------------------------------------------------ contour.gridData = function(x, addImage = TRUE, ...) { # A function implemented by Diethelm Wuertz # Description: # S3 method to generate a contour plot from a grid data object # Example: # x = y = seq(-10, 10, length = 30) # z = outer(x, y, function(x, y) { r <- sqrt(x^2+y^2); 10 * sin(r)/r }) # data = list(x = x, y = y, z = z) # class(data) = "gridData" # contour(data) # FUNCTION: # Grid Data: class(x) = "default" if (addImage) image(x, ...) contour(x, add = addImage, ...) box() # Return Value: invisible(NULL) } ################################################################################ fCopulae/inst/obsolete/R/bv-dt.R0000644000176000001440000001017212406047540016174 0ustar ripleyusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA # Copyrights (C) # for this R-port: # 1999 - 2007, Diethelm Wuertz, GPL # Diethelm Wuertz # info@rmetrics.org # www.rmetrics.org # for the code accessed (or partly included) from other R-ports: # see R's copyright and license files # for the code accessed (or partly included) from contributed R-ports # and other sources # see Rmetrics's copyright file ################################################################################ # FUNCTION: BIVARIATE STUDENT-T DISTRIBUTION: # pt2d Computes bivariate Student-t probability function # dt2d Computes bivariate Student-t density function # rt2d Generates bivariate Student-t random deviates ################################################################################ pt2d = function(x, y = x, rho = 0, nu = 4) { # pnorm2d: A copy from R package "sn" # Description: # Computes bivariate Student-t probability function # Arguments: # x, y - two numeric values or vectors of the same length at # which the probability will be computed. # Example: # pt2d(rnorm(5), rnorm(5), 0.5, 5) # Value: # returns a numeric vector of probabilities of the same length # as the input vectors # FUNCTION: # Normal Limit: if (nu == Inf) return(pnorm2d(x = x, y = y, rho = rho)) # Settings: sigma = diag(2) sigma[1, 2] = sigma[2, 1] = rho X = cbind(x, y) # Probaility: ans = pmvst(X, dim = 2, mu = c(0, 0), Omega = sigma, alpha = c(0, 0), df = nu) attr(ans, "control") = c(rho = rho, nu = nu) # Return Value: ans } # ------------------------------------------------------------------------------ dt2d = function(x, y = x, rho = 0, nu = 4) { # A function implemented by Diethelm Wuertz # Arguments: # n - number of random deviates to be generated # rho - the linear correlation, a numeric value between # minus one and one. # Description: # Computes bivariate Student-t density function # Example: # dt2d(rnorm(5), rnorm(5), 0.5, 5) # Note: # Partly copied from contributed R package 'sn' # FUNCTION: # Normal Limit: if (nu == Inf) return(dnorm2d(x = x, y = y, rho = rho)) # Argument: xoy = (x^2 - 2*rho*x*y + y^2)/ (2*(1 - rho^2)) # Density: density = (1 + 2*xoy/nu)^(-(nu+2)/2) / (2*pi*sqrt(1-rho^2)) attr(density, "control") = c(rho = rho, nu = nu) # Return value: density } # ------------------------------------------------------------------------------ rt2d = function(n, rho = 0, nu = 4) { # A function implemented by Diethelm Wuertz # Description: # Generates bivariate Student-t random deviates # Arguments: # n - number of random deviates to be generated # rho - the linear correlation, a numeric value between # minus one and one. # Note: # Partly copied from contributed R package 'mvtnorm' # Author Friedrich Leisch # FUNCTION: # Normal Limit: if (nu == Inf) return(rnorm2d(n = n, rho = rho)) # Random Deviates: ans = rnorm2d(n, rho)/sqrt(rchisq(n, nu)/nu) attr(ans, "control") = c(rho = rho, nu = nu) # Return Value: ans } ################################################################################ fCopulae/tests/0000755000176000001440000000000012406047540013204 5ustar ripleyusersfCopulae/tests/doRUnit.R0000644000176000001440000000151612406047540014716 0ustar ripleyusers#### doRUnit.R --- Run RUnit tests ####------------------------------------------------------------------------ ### Origianlly follows Gregor Gojanc's example in CRAN package 'gdata' ### and the corresponding section in the R Wiki: ### http://wiki.r-project.org/rwiki/doku.php?id=developers:runit ### MM: Vastly changed: This should also be "runnable" for *installed* ## package which has no ./tests/ ## ----> put the bulk of the code e.g. in ../inst/unitTests/runTests.R : if(require("RUnit", quietly = TRUE)) { ## --- Setup --- wd <- getwd() pkg <- sub("\\.Rcheck$", '', basename(dirname(wd))) library(package=pkg, character.only = TRUE) path <- system.file("unitTests", package = pkg) stopifnot(file.exists(path), file.info(path.expand(path))$isdir) source(file.path(path, "runTests.R"), echo = TRUE) } fCopulae/NAMESPACE0000644000176000001440000000067112406047540013265 0ustar ripleyusers################################################################################ ## Exports ################################################################################ exportPattern("^[^\\.]") ############################################################################### ## Imports ################################################################################ import(timeDate) import(timeSeries) import(fBasics) import(fMultivar) fCopulae/R/0000755000176000001440000000000012406047540012243 5ustar ripleyusersfCopulae/R/ArchimedeanGenerator.R0000644000176000001440000023273312406047540016447 0ustar ripleyusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA ################################################################################ # FUNCTION: ARCHIMEDEAN COPULAE PARAMETER: # archmList Returns list of implemented Archimedean copulae # archmParam Sets Default parameters for an Archimedean copula # archmRange Returns the range of valid alpha values # archmCheck Checks if alpha is in the valid range # FUNCTION: ARCHIMEDEAN COPULAE PHI GENERATOR: # Phi Computes Archimedean Phi, inverse and derivatives # PhiSlider Displays interactively generator function # .Phi Computes Archimedean generator Phi # .Phi0 Utility Function # .PhiFirstDer Computes first derivative of Phi # .PhiSecondDer Computes second derivative of Phi # .invPhi Computes inverse of Archimedean generator # .invPhiFirstDer Computes first derivative of inverse Phi # .invPhiSecondDer Computes second derivative of inverse Phi # FUNCTION: ARCHIMEDEAN DENSITY K GENERATOR: # Kfunc Computes Archimedean Density Kc and its Inverse # KfuncSlider Displays interactively the density and concordance # .Kfunc Computes Density for Archimedean Copulae # .invK Computes Inverse of Density # .invK2 Utility Function # .ALPHA Utility Function # .TAU Utility Function # .RHO Utility Function ################################################################################ ################################################################################ # FUNCTION: ARCHIMEDEAN COPULAE PARAMETER: # archmList Returns list of implemented Archimedean copulae # archmParam Sets default parameters for an Archimedean copula # archmCheck Checks if alpha is in the valid range # archmRange Returns the range of valid alpha values archmList <- function() { # A function implemented by Diethelm Wuertz # Description: # Returns list of implemented Archimedean copulae # Compose List: ans <- paste(1:22) # Return Value: ans } # ------------------------------------------------------------------------------ archmParam <- function(type = archmList()) { # A function implemented by Diethelm Wuertz # Description: # Sets default parameters for Archimedean copulae # Arguments: # type - a character string or integer value naming the copula. # By default the first copula will be chosen. # Value: # returns a list with two elements, 'param' sets the parameters # which may be a vector, 'range' the range with minimum and # maximum values for each of the parameters. # FUNCTION: # Type: type = match.arg(type) Type = as.integer(type) # Parameter Values: B = Inf lower=c(-1, 1,-1, 1,-B, 1, 0, 1, 0, 0, 0, 1, 0, 1, 1, 0,-B, 2, 0, 0, 1, 0) upper=c( B, B, 1, B, B, B, 1, B, 1, 1,.5, B, B, B, B, B, B, B, B, B, B, 1) Alpha=c( 1, 2,.5, 2, 1, 2, .5, 2,.5,.5,.2, 2, 1, 2, 2, 1,.5, 3, 1, 1, 2,.5) # Parameter List: ans = list(copula = type) ans$param = c(alpha = Alpha[Type]) ans$range = c(lower = lower[Type], upper = upper[Type]) # Return Value: ans } # ------------------------------------------------------------------------------ archmRange <- function(type = archmList(), B = Inf) { # A function implemented by Diethelm Wuertz # Description: # Returns the range of valid alpha values # FUNCTION: # Type: type = match.arg(type) Type = as.integer(type) # Range: lower = c(-1, 1,-1, 1,-B, 1, 0, 1, 0, 0, 0, 1, 0, 1, 1, 0,-B, 2, 0, 0, 1, 0) upper = c( B, B, 1, B, B, B, 1, B, 1, 1,.5, B, B, B, B, B, B, B, B, B, B, 1) # Return Value: ans = cbind(lower[Type], upper[Type]) rownames(ans) = type colnames(ans) = c("lower", "upper") ans } # ------------------------------------------------------------------------------ archmCheck <- function(alpha, type = archmList()) { # A function implemented by Diethelm Wuertz # Description: # Checks if alpha is in the valid range # FUNCTION: # Type: type = match.arg(type) # Check: ans = TRUE range = as.vector(archmRange(type)) if (alpha < range[1] | alpha > range[2]) { print(c(alpha = alpha)) print(c(range = range)) stop("alpha is out of range") } # Return Value: invisible(TRUE) } ################################################################################ # FUNCTION: ARCHIMEDEAN COPULAE PHI GENERATOR: # Phi Computes Archimedean Phi, inverse and derivatives # PhiSlider Displays interactively generator function # .Phi Computes Archimedean generator Phi # .Phi0 Utility Function # .PhiFirstDer Computes first derivative of Phi # .PhiSecondDer Computes second derivative of Phi # .invPhi Computes inverse of Archimedean generator # .invPhiFirstDer Computes first derivative of inverse Phi # .invPhiSecondDer Computes second derivative of inverse Phi Phi <- function(x, alpha = NULL, type = archmList(), inv = FALSE, deriv = paste(0:2)) { # A function implemented by Diethelm Wuertz # Type: type = match.arg(type) Type = as.integer(type) deriv = match.arg(deriv) # Default alpha: if (is.null(alpha)) alpha = archmParam(type)$param # Check alpha: check = archmCheck(alpha, type) # Phi Generator: if (inv) { if (deriv == "0") { ans = .invPhi(x, alpha, type) names(ans) = "invPhi" } if (deriv == "1") { ans = .invPhiFirstDer(x, alpha, type) names(ans) = "invPhiFirstDer" } if (deriv == "2") { ans = .invPhiSecondDer(x, alpha, type) names(ans) = "invPhiSecondDer" } } else { if (deriv == "0") { ans = .Phi(x, alpha, type) names(ans) = "Phi" } if (deriv == "1") { ans = .PhiFirstDer(x, alpha, type) names(ans) = "PhiFirstDer" } if (deriv == "2") { ans = .PhiSecondDer(x, alpha, type) names(ans) = "PhiSecondDer" } } # Add Control Attribute: attr(ans, "control")<-cbind.data.frame(alpha = alpha, type = type, inv = inv, deriv = deriv, row.names = "") # Return Value: ans } # ------------------------------------------------------------------------------ PhiSlider <- function(B = 5) { # A function implemented by Diethelm Wuertz # Description: # Displays interactively the dependence function # FUNCTION: # Graphic Frame: par(mfcol = c(2, 2), cex = 0.7) # Internal Function: refresh.code = function(...) { # Startup Counter: .counter <- getRmetricsOptions(".counter") + 1 setRmetricsOptions(.counter = .counter) if (.counter < 10) return () # Sliders: Copula = as.integer(.sliderMenu(no = 1)) Counter = c(1,2,3,2,4,2,5,2,5,5,6,2,7,2,2,7,4,8,7,7,2,5) No = Counter[Copula] N = .sliderMenu(no = 2) alpha = .sliderMenu(no = No+2) # Skip: if (Copula == 13 & alpha == 0) return(invisible()) # Do we have a strict Copula? strict = c( "Yes","No","Yes","Yes","Yes","Yes","No","No","Yes","Yes", "No","Yes","Yes","Yes","No","Yes","Yes","No","Yes","Yes", "No","Yes")[Copula] if (alpha < 0 & Copula == 1) strict[1] = "No" if (alpha == 0 & Copula == 16) strict[16] = "No" # What is the Range? RANGE = c( "-1|Inf", "1|Inf", "-1|1", "-Inf|inf", "0|1", "0|0.5", "0|Inf", "2|Inf")[No] # Which one is the Limit Copula? limitTitle = rep("NA", times = 22) if (alpha == -1) limitTitle = c( "W ", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "Pi", "NA", "NA", "NA", "NA", "NA") if (alpha == 0) limitTitle = c( "Pi", "NA", "Pi", "NA", "Pi", "NA", "W ", "NA", "Pi", "Pi", "Pi", "NA", "NA", "NA", "NA", "W ", "NA", "NA", "L ", "Pi", "NA", "Pi") if (alpha == 1) limitTitle = c( "L ", "W ", "L ", "Pi", "NA", "Pi", "Pi", "W ", "NA", "NA", "NA", "L ", "Pi", "L ", "W ", "NA", "NA", "NA", "NA", "NA", "W ", "NA") limitTitle = limitTitle[Copula] if (limitTitle == "NA") { limitTitle = " " } else { limitTitle = paste(" Copula = ", limitTitle[1]) } # Plot phi: x = (0:N)/N Title = paste("Generator Phi - Copula No:", as.character(Copula), "\nalpha = ", as.character(alpha), " Strict = ", strict, limitTitle) phi.0 = .Phi(x = 0, alpha = alpha, type = as.character(Copula)) y = .Phi(x = x, alpha = alpha, type = as.character(Copula)) x = x[y < 1e6] y = y[y < 1e6] if (is.finite(y[1])) ylim = c(0, y[1]) else ylim = c(0, y[2]) plot(x = x, y = y, type = "l", ylim = ylim, main = Title[1], xlab = "t", ylab = paste("Phi |", RANGE)) if (N < 100) points(x = x, y = y, pch = 19, cex = 0.5) y.inv = .invPhi(x = y, alpha = alpha, type = as.character(Copula)) lines(x = y.inv, y = y, col = "red", lty = 3) abline(h = 0, lty = 3) points(0, phi.0, col = "red", pch = 19) # Plot phi first and second Derivative: y1 = .PhiFirstDer(x = x, alpha = alpha, type = as.character(Copula)) y2 = .PhiSecondDer(x = x, alpha = alpha, type = as.character(Copula)) r1 = max(abs(y1[is.finite(y1)])) r2 = max(abs(y2[is.finite(y2)])) if (r2 == 0) r2 = 1 plot(x = x, y = y1/r1, ylim = c(-1, 1), type = "l", xlab = "t", ylab = "Derivatives", main = "Phi first and second Derivative", col = "blue") if (N < 100) points(x = x, y = y1/r1, pch = 19, cex = 0.5) lines(x = x, y = y2/r2, col = "red") if (N < 100) points(x = x, y = y2/r2, pch = 19, cex = 0.5) abline(h = 0, lty = 3) mtext("First ", 4, col = "blue", cex = 0.75) mtext(" Second", 4, col = "red ", cex = 0.75) mtext(paste("x", as.character(round(r1, digits = 2))), 1, line = -2, col = "blue", cex = 0.75) mtext(paste("x", as.character(round(r2, digits = 2))), 3, line = -2, col = "red", cex = 0.75) # Plot invPhi: Title = paste( "Inverse Phi\n Phi(0) =", as.character(round(phi.0, digits = 3))) plot(x = y, y = y.inv, type = "l", main = Title, xlab = paste("Phi |", RANGE), ylab = "t") if (N < 100) points(x = y, y = y.inv, pch = 19, cex = 0.5) abline(h = 0, lty = 3) points(phi.0, 0, col = "red", pch = 19) # Plot invPhi first & second Derivative: y = y[y < .Phi0(alpha, Copula)] Title = "Inverse Phi 1st Derivative" y1.inv = .invPhiFirstDer(x = y, alpha = alpha, type = as.character(Copula)) y2.inv = .invPhiSecondDer(x = y, alpha = alpha, type = as.character(Copula)) r1 = max(abs(y1.inv[is.finite(y1.inv)])) r2 = max(abs(y2.inv[is.finite(y2.inv)])) if (r2 == 0) r2 = 1 plot(x = y, y = y1.inv/r1, ylim = c(-1, 1), type = "l", xlim = range(y), xlab = paste("Phi |", RANGE), ylab = "dewrivatives", main = "Inv Phi first and second Derivative", col = "blue") if (N < 100) points(x = y, y = y1.inv/r1, pch = 19, cex = 0.5) lines(x = y, y = y2.inv/r2, col = "red") if (N < 100) points(x = y, y = y2.inv/r2, pch = 19, cex = 0.5) abline(h = 0, lty = 3) mtext("First ", 4, col = "blue", cex = 0.75) mtext(" Second", 4, col = "red ", cex = 0.75) mtext(paste("x", as.character(round(r1, digits = 2))), 1, line = -2, col = "blue", cex = 0.75) mtext(paste("x", as.character(round(r2, digits = 2))), 3, line = -2, col = "red", cex = 0.75) # Reset Frame: par(mfcol = c(2, 2), cex = 0.7) } # Open Slider Menu: setRmetricsOptions(.counter = 10) C1 = "1: [-1,Inf]" C2 = "2-4-6-8-12-14-15-21: [1,Inf)" C3 = "3: [-1,1)" C4 = "5-17: (-Inf,Inf)|{0}" C5 = "7-9-10-22: (0,1]" C6 = "11: (0, 1/2]" C7 = "13-16-19-20: (0,Inf)" C8 = "18: [2, Inf)" C = c( C1, C2, C3, C4, C5, C6, C7, C8 ) L = c( -1, 1, -1, -B, 0, 0, 0, 2 ) U = c(3*B/5, B, 1, B, 1, 0.5, B/2, 2*B ) A = c( 0.5, 2, 0.5, 1, 0.5, 0.2, 1, 3 ) V = rep(0.01, 20) .sliderMenu(refresh.code, names = c("Copula", "N", C), minima = c( 1, 10, L), maxima = c( 22, 1000, U), resolutions = c( 1, 10, V), starts = c( 1, 100, A)) } # ------------------------------------------------------------------------------ .Phi <- function(x, alpha = NULL, type = archmList()) { # A function implemented by Diethelm Wuertz # Description: # Computes Archimedean generator "phi" # FUNCTION: # Type: type = match.arg(type) Type = as.integer(type) # Missing x: if (missing(x)) x = (0:10)/10 # Alpha: if (is.null(alpha)) alpha = archmParam(type)$param # Check alpha: check = archmCheck(alpha, type) # As listed in Nelsen: N = length(x) Type = "NA" if (type == 1) if (alpha == -1) Type = "W" else if (alpha == 0) Type = "Pi" else if (alpha == 1) Type = "L" else f = 1/alpha*(x^(-alpha)-1) # Clayton if (type == 2) if (alpha == 1) Type = "W" else f = (1-x)^alpha if (type == 3) if (alpha == 0) Type = "Pi" else if (alpha == 1) Type = "L" else f = log((1-alpha*(1-x))/x) # Ali-Mikhail-Haq if (type == 4) if (alpha == 1) Type = "Pi" else f = (-log(x))^alpha # Gumbel-Hougard if (type == 5) if (alpha == 0) Type = "Pi" else f = -log((exp(-alpha*x)-1)/(exp(-alpha)-1)) # Frank if (type == 6) if (alpha == 1) Type = "Pi" else f = -log(1-(1-x)^alpha) # Joe if (type == 7) if (alpha == 0) Type = "W" else if (alpha == 1) Type = "Pi" else f = -log(alpha*x+(1-alpha)) if (type == 8) if (alpha == 0) Type = "Pi" else f = (1-x)/(1+x*(alpha-1)) if (type == 9) if (alpha == 0) Type = "Pi" else f = log(1-alpha*log(x)) # Gumbel-Barnett if (type == 10) if (alpha == 0) Type = "Pi" else f = log(2*x^(-alpha)-1) if (type == 11) if (alpha == 0) Type = "Pi" else f = log(2-x^alpha) if (type == 12) if (alpha == 1) Type = "L" else f = (1/x-1)^alpha if (type == 13) if (alpha == 1) Type = "Pi" else f = (1-log(x))^alpha-1 if (type == 14) if (alpha == 1) Type = "L" else f = (x^(-1/alpha)-1)^alpha if (type == 15) if (alpha == 1) Type = "W" else f = (1-x^(1/alpha))^alpha if (type == 16) if (alpha == 0) Type = "W" else f = (alpha/x+1)*(1-x) if (type == 17) if (alpha == -1) Type = "Pi" else f = -log(((1+x)^(-alpha)-1)/(2^(-alpha)-1)) if (type == 18) f = exp(alpha/(x-1)) if (type == 19) if (alpha == 0) Type = "L" else f = exp(alpha/x)-exp(alpha) if (type == 20) if (alpha == 0) Type = "Pi" else f = exp(x^(-alpha))-exp(1) if (type == 21) if (alpha == 1) Type = "W" else f = (1-(1-(1-x)^alpha)^(1/alpha)) if (type == 22) if (alpha == 0) Type = "Pi" else f = asin(1-x^alpha) if (Type == "Pi") f = -log(x) if (Type == "W") f = 1-x if (Type == "L") f = 1/x - 1 f[x == 0] = .Phi0(alpha, type) # Return Value: f } # ------------------------------------------------------------------------------ .Phi0 <- function(alpha, type) { # A function implemented by Diethelm Wuertz # Phi(0): type <- as.integer(type) if (type == 1) phi0 = if (alpha < 0) -1/alpha else Inf else if (type == 2) phi0 = 1 else if (type == 3) phi0 = Inf else if (type == 4) phi0 = Inf else if (type == 5) phi0 = Inf else if (type == 6) phi0 = Inf else if (type == 7) phi0 = if (alpha == 0) 1 else -log(1 - alpha) else if (type == 8) phi0 = 1 else if (type == 9) phi0 = Inf else if (type == 10) phi0 = Inf else if (type == 11) phi0 = if (alpha == 0) Inf else log(2) else if (type == 12) phi0 = Inf else if (type == 13) phi0 = Inf else if (type == 14) phi0 = Inf else if (type == 15) phi0 = 1 else if (type == 16) phi0 = if (alpha == 0) 1 else Inf else if (type == 17) phi0 = Inf else if (type == 18) phi0 = exp(-alpha) else if (type == 19) phi0 = Inf else if (type == 20) phi0 = Inf else if (type == 21) phi0 = 1 else if (type == 22) phi0 = if (alpha == 0) Inf else pi/2 # Return Value: phi0 } # ------------------------------------------------------------------------------ .PhiFirstDer <- function(x, alpha = NULL, type = archmList()) { # A function implemented by Diethelm Wuertz # Description: # Computes Derivative of Archimedean generator. # FUNCTION: # Type: type = match.arg(type) Type = as.integer(type) # Missing x: if (missing(x)) x = (0:10)/10 # Alpha: if (is.null(alpha)) alpha = archmParam(type)$param # Check alpha: check = archmCheck(alpha, type) # FUNCTION: # The functions were created by MAPLE: N = length(x) cType = "NA" if (Type == 1) if (alpha == -1) cType = "W" else if (alpha == 0) cType = "Pi" else if (alpha == 1) cType = "L" else f1 = -x^(-alpha-1) if (Type == 2) if (alpha == 1) cType = "W" else f1 = -(1-x)^alpha*alpha/(1-x) if (Type == 3) if (alpha == 0) cType = "Pi" else if (alpha == 1) cType = "L" else f1 = (alpha/x-(1-alpha*(1-x))/x^2)/(1-alpha*(1-x))*x if (Type == 4) if (alpha == 1) cType = "Pi" else f1 = (-log(x))^alpha*alpha/x/log(x) if (Type == 5) if (alpha == 0) cType = "Pi" else f1 = alpha*exp(-alpha*x)/(exp(-alpha*x)-1) if (Type == 6) if (alpha == 1) cType = "Pi" else f1 = -(1-x)^alpha*alpha/(1-x)/(1-(1-x)^alpha) if (Type == 7) if (alpha == 0) cType = "W" else if (alpha == 1) cType = "Pi" else f1 = -alpha/(alpha*x+1-alpha) if (Type == 8) if (alpha == 1) cType = "W" else f1 = -1/(1+x*(-1+alpha))-(1-x)/(1+x*(-1+alpha))^2*(-1+alpha) if (Type == 9) if (alpha == 0) cType = "Pi" else f1 = -alpha/x/(1-alpha*log(x)) if (Type == 10) if (alpha == 0) cType = "Pi" else f1 = -2*x^(-alpha)*alpha/x/(2*x^(-alpha)-1) if (Type == 11) if (alpha == 0) cType = "Pi" else f1 = -x^alpha*alpha/x/(2-x^alpha) if (Type == 12) if (alpha == 1) cType = "L" else f1 = -(1/x-1)^alpha*alpha/x^2/(1/x-1) if (Type == 13) if (alpha == 1) cType = "Pi" else f1 = -(1-log(x))^alpha*alpha/x/(1-log(x)) if (Type == 14) if (alpha == 1) cType = "L" else f1 = -(x^(-1/alpha)-1)^alpha*x^(-1/alpha)/x/(x^(-1/alpha)-1) if (Type == 15) if (alpha == 1) cType = "W" else f1 = -(1-x^(1/alpha))^alpha*x^(1/alpha)/x/(1-x^(1/alpha)) if (Type == 16) if (alpha == 0) cType = "W" else f1 = -alpha/x^2*(1-x)-alpha/x-1 if (Type == 17) if (alpha == -1) cType = "Pi" else f1 = (1+x)^(-alpha)*alpha/(1+x)/((1+x)^(-alpha)-1) if (Type == 18) f1 = -alpha/(-1+x)^2*exp(alpha/(-1+x)) if (Type == 19) if (alpha == 0) cType = "L" else f1 = -alpha/x^2*exp(alpha/x) if (Type == 20) if (alpha == 0) cType = "Pi" else f1 = -x^(-alpha)*alpha/x*exp(x^(-alpha)) if (Type == 21) if (alpha == 1) cType = "W" else f1 = -(1-(1-x)^alpha)^(-(-1+alpha)/alpha)*(1-x)^(-1+alpha) if (Type == 22) if (alpha == 0) cType = "Pi" else f1 = -x^(-1+alpha)*alpha/(2*x^alpha-x^(2*alpha))^(1/2) if (cType == "Pi") f1 = -1/x if (cType == "W") f1 = rep(-1, times = N) if (cType == "L") f1 = -1/x^2 # Return Value: f1 } # ------------------------------------------------------------------------------ .PhiSecondDer <- function(x, alpha = NULL, type = archmList()) { # A function implemented by Diethelm Wuertz # Description: # Computes Derivative of Archimedean generator. # FUNCTION: # Type: type = match.arg(type) Type = as.integer(type) # Missing x: if (missing(x)) x = (0:10)/10 # Alpha: if (is.null(alpha)) alpha = archmParam(type)$param # Check alpha: check = archmCheck(alpha, type) # FUNCTION: # The functions were created by MAPLE: a = alpha N = length(x) cType = "NA" if (Type == 1) if (alpha == -1) cType = "W" else if (alpha == 0) cType = "Pi" else if (alpha == 1) cType = "L" else f2 = x^(-a-2)*a+x^(-a-2) if (Type == 2) if (alpha == 1) cType = "W" else f2 = (1-x)^(a-2)*a^2-(1-x)^(a-2)*a if (Type == 3) if (alpha == 0) cType = "Pi" else if (alpha == 1) Type = "L" else f2 = -1/x^2*(a-1)*(1-a+2*x)/(1-a+x)^2 if (Type == 4) if (alpha == 1) cType = "Pi" else f2 = a*((-log(x))^(a-2)*a+(-log(x))^(a-1)-(-log(x))^(a-2))/x^2 if (Type == 5) if (alpha == 0) cType = "Pi" else f2 = a^2*exp(-a*x)/(exp(-a*x)-1)^2 if (Type == 6) if (alpha == 1) cType = "Pi" else f2 = a*((1-x)^(a-2)*a-(1-x)^(a-2)+(1-x)^(2*a-2))/(-1+(1-x)^a)^2 if (Type == 7) if (alpha == 0) cType = "W" else if (alpha == 1) cType = "Pi" else f2 = alpha^2/(alpha*x+1-alpha)^2 if (Type == 8) if (alpha == 1) cType = "W" else f2 = 2*(a-1)*a/(1+a*x-x)^3 if (Type == 9) if (alpha == 0) cType = "Pi" else f2 = -a*(-1+a*log(x)+a)/x^2/(-1+a*log(x))^2 if (Type == 10) if (alpha == 0) cType = "Pi" else f2 = -2*a*(x^a*a-2+x^a)/(-2+x^a)^2/x^2 if (Type == 11) if (alpha == 0) cType = "Pi" else f2 = -a*(2*x^(a-2)*a-2*x^(a-2)+x^(2*a-2))/(-2+x^a)^2 if (Type == 12) if (alpha == 1) cType = "L" else f2 = -(-(x-1)/x)^a*a*(-a+2*x-1)/x^2/(x-1)^2 if (Type == 13) if (alpha == 1) cType = "Pi" else f2 = a*((1-log(x))^(a-2)*a+(1-log(x))^(a-1)-(1-log(x))^(a-2))/x^2 if (Type == 14) if (alpha == 1) cType = "L" else f2 = ((x^(-1/a)-1)^(a-2)*x^(-2*(a+1)/a)*a+(x^(-1/a)-1)^(a-1) * x^(-(1+2*a)/a)+(x^(-1/a)-1)^(a-1)*x^(-(1+2*a)/a) * a-(x^(-1/a)-1)^(a-2)*x^(-2*(a+1)/a))/a if (Type == 15) if (alpha == 1) cType = "W" else f2 = ((1-x^(1/a))^(a-2)*x^(-2*(a-1)/a)*a-(1-x^(1/a))^(a-1) * x^(-(-1+2*a)/a)+(1-x^(1/a))^(a-1)*x^(-(-1+2*a)/a) * a-(1-x^(1/a))^(a-2)*x^(-2*(a-1)/a))/a if (Type == 16) if (alpha == 0) cType = "W" else f2 = 2*a/x^3 if (Type == 17) if (alpha == -1) cType = "Pi" else f2 = a*((1+x)^(a-2)*a+2*(1+x)^(a-2)*a*x+(1+x)^(a-2)*a*x^2 - 1+(1+x)^(a-2)+2*(1+x)^(a-2)*x+(1+x)^(a-2)*x^2) / (-1+(1+x)^a)^2/(1+x)^2 if (Type == 18) f2 = a*exp(a/(x-1))*(2*x-2+a)/(x-1)^4 if (Type == 19) if (alpha == 0) cType = "L" else f2 = a*exp(a/x)*(2*x+a)/x^4 if (Type == 20) if (alpha == 0) cType = "Pi" else f2 = a*exp(x^(-a))*(x^(-a-2)*a+x^(-a-2)+x^(-2*a-2)*a) if (Type == 21) if (alpha == 1) cType = "W" else f2 = -(1-(1-x)^a)^(-(-1+2*a)/a)*(1-x)^(2*a-2) + (1-(1-x)^a)^(-(-1+a)/a)*(1-x)^(a-2)*a - (1-(1-x)^a)^(-(-1+a)/a)*(1-x)^(a-2) + (1-(1-x)^a)^(-(-1+2*a)/a)*(1-x)^(2*a-2)*a if (Type == 22) if (alpha == 0) cType = "Pi" else f2 = -a/x^2*(a*x^(2*a)-2*x^(2*a)+x^(3*a))/(2*x^a-x^(2*a))^(3/2) if (cType == "Pi") f2 = 1/x^2 if (cType == "W") f2 = rep(0, times = N) if (cType == "L") f2 = 2/x^3 # Return Value: f2 } # ------------------------------------------------------------------------------ .invPhi <- function(x, alpha = NULL, type = archmList()) { # A function implemented by Diethelm Wuertz # Description: # Computes inverse of Archimedean generator. # FUNCTION: # Type: type <- match.arg(type) Type <- as.integer(type) # Missing x: if (missing(x)) x = (0:10)/10 # Alpha: if (is.null(alpha)) alpha = archmParam(type)$param # Check alpha: check <- archmCheck(alpha, type) # Inverse Generator: N = length(x) cType = "NA" if (Type == 1) if (alpha == -1) cType = "W" else if (alpha == 0) cType = "Pi" else if (alpha == 1) cType = "L" else finv = exp(-log(1 + alpha*x)/alpha) if (Type == 2) if (alpha == 1) cType = "W" else finv = 1 - x^(1/alpha) if (Type == 3) if (alpha == 0) cType = "Pi" else if (alpha == 1) cType = "L" else finv = (1-alpha) / (exp(x)-alpha) if (Type == 4) if (alpha == 1) cType = "Pi" else finv = exp(-x^(1/alpha)) if (Type == 5) if (alpha == 0) cType = "Pi" else finv = -log(1+exp(-x)*( exp(-alpha)-1 ) ) / alpha if (Type == 6) if (alpha == 1) cType = "Pi" else finv = 1 - (1 - exp(-x))^(1/alpha) if (Type == 7) if (alpha == 0) cType = "W" else if (alpha == 1) Type = "Pi" else finv = (1-exp(x)+alpha*exp(x))/alpha/exp(x) if (Type == 8) if (alpha == 1) cType = "W" else finv = (1-x) / ((alpha-1)*x+1) if (Type == 9) if (alpha == 0) cType = "Pi" else finv = exp((1-exp(x))/alpha) if (Type == 10) if (alpha == 0) cType = "Pi" else finv = ((1+exp(x))/2 )^(-1/alpha) if (Type == 11) if (alpha == 0) cType = "Pi" else finv = (2-exp(x))^(1/alpha) if (Type == 12) if (alpha == 1) cType = "L" else finv = 1/(1+x^(1/alpha)) if (Type == 13) if (alpha == 1) cType = "Pi" else finv = exp(1-(1+x)^(1/alpha)) if (Type == 14) if (alpha == 1) cType = "L" else finv = (1+x^(1/alpha))^(-alpha) if (Type == 15) if (alpha == 1) cType = "W" else finv = (1-x^(1/alpha))^alpha if (Type == 16) if (alpha == 0) cType = "W" else finv = (1-alpha-x)/2 + sqrt(((1-alpha-x)^2)/4+alpha) if (Type == 17) if (alpha == -1) cType = "Pi" else finv = (exp(-x)*(2^(-alpha)-1)+1)^(-1/alpha) - 1 if (Type == 18) finv = 1+alpha/log(x) if (Type == 19) if (alpha == 0) cType = "L" else finv = alpha / log(x+exp(alpha)) if (Type == 20) if (alpha == 0) cType = "Pi" else finv = exp( -log((log(x+exp(1))))/alpha) if (Type == 21) if (alpha == 1) cType = "W" else finv = 1-(1-(1-x)^alpha)^(1/alpha) if (Type == 22) if (alpha == 0) cType = "Pi" else finv = (1-sin(x))^(1/alpha) if (cType == "Pi") finv = exp(-x) if (cType == "W") finv = 1 - x if (cType == "L") finv = 1 / (x+1) # Large x Limit: finv[which(x >= .Phi0(alpha, type))] = 0 # Return Value: finv } # ------------------------------------------------------------------------------ .invPhiFirstDer <- function(x, alpha = NULL, type = archmList()) { # A function implemented by Diethelm Wuertz # Description: # Computes first Derivative of inverse Archimedean generator. # FUNCTION: # Type: type = match.arg(type) Type = as.integer(type) # Missing x: if (missing(x)) x = (0:10)/10 # Alpha: if (is.null(alpha)) alpha = archmParam(type)$param # Check alpha: check = archmCheck(alpha, type) # Generator: N = length(x) cType = "NA" a = alpha y = x ln = log if (Type == 1) if (alpha == -1) cType = "W" else if (alpha == 0) cType = "Pi" else if (alpha == 1) cType = "L" else finv1 = -(1+y*a)^(-(a+1)/a) if (Type == 2) if (alpha == 1) cType = "W" else finv1 = -y^(-(a-1)/a)/a if (Type == 3) if (alpha == 0) cType = "Pi" else if (alpha == 1) cType = "L" else finv1 = (a-1)/(exp(y)-1)^2*exp(y) if (Type == 4) if (alpha == 1) cType = "Pi" else finv1 = -y^(-(a-1)/a)/a*exp(-y^(1/a)) if (Type == 5) if (alpha == 0) cType = "Pi" else finv1 = (-1+exp(a))/(-1+exp(a)-exp(y+a))/a if (Type == 6) if (alpha == 1) cType = "Pi" else finv1 = -exp(-(-ln(exp(y)-1)+y)/a)/(exp(y)-1)/a if (Type == 7) if (alpha == 0) cType = "W" else if (alpha == 1) Type = "Pi" else finv1 = (-exp(y)+a*exp(y))/a/exp(y)-(1-exp(y)+a*exp(y))/a/exp(y) if (Type == 8) if (alpha == 1) cType = "W" else finv1 = -a/(1+y*a-y)^2 if (Type == 9) if (alpha == 0) cType = "Pi" else finv1 = -1/a*exp((y*a-exp(y)+1)/a) if (Type == 10) if (alpha == 0) cType = "Pi" else finv1 = -1/(exp(y)+1)/a*exp((y*a+ln(2)-ln(exp(y)+1))/a) if (Type == 11) if (alpha == 0) cType = "Pi" else finv1 = -(-exp(y)+2)^(-(a-1)/a)/a*exp(y) if (Type == 12) if (alpha == 1) cType = "L" else finv1 = -1/(y^(1/a)+1)^2*y^(-(a-1)/a)/a if (Type == 13) if (alpha == 1) cType = "Pi" else finv1 = -(1+y)^(-(a-1)/a)/a*exp(-(1+y)^(1/a)+1) if (Type == 14) if (alpha == 1) cType = "L" else finv1 = -(y^(1/a)+1)^(-a-1)*y^(-(a-1)/a) if (Type == 15) if (alpha == 1) cType = "L" else finv1 = -(-y^(1/a)+1)^(a-1)*y^(-(a-1)/a) if (Type == 16) if (alpha == 0) cType = "W" else finv1 = -1/2+1/4/(a^2+2*a+2*a*y+1-2*y+y^2)^(1/2)*(2*a-2+2*y) if (Type == 17) if (alpha == -1) cType = "Pi" else finv1 = -(2^(-a)-1+exp(y))^(-1/a)*exp(1/a*y) * (-1+2^a)/a/(1-2^a+exp(y)*2^a) if (Type == 18) finv1 = -a/ln(y)^2/y if (Type == 19) if (alpha == 0) cType = "L" else finv1 = -a/ln(exp(a)+y)^2/(exp(a)+y) if (Type == 20) if (alpha == 0) cType = "Pi" else finv1 = -ln(exp(1)+y)^(-(a+1)/a)/a/(exp(1)+y) if (Type == 21) if (alpha == 1) cType = "W" else finv1 = -exp((log(1-y)*a^2+log(-(1-y)^a+1))/a)/(-1+y)/((1-y)^a-1) if (Type == 22) if (alpha == 0) cType = "Pi" else finv1 = -cos(y)*(1-sin(y))^(-(-1+a)/a)/a if (cType == "Pi") finv1 = -exp(-x) if (cType == "W") finv1 = rep(-1, times = N) if (cType == "L") finv1 = -1 / (x+1)^2 # Large x Limit: finv1[which(x >= .Phi0(a, type))] = 0 # Return Value: finv1 } # ------------------------------------------------------------------------------ .invPhiSecondDer <- function(x, alpha = NULL, type = archmList()) { # A function implemented by Diethelm Wuertz # Description: # Computes first Derivative of inverse Archimedean generator. # FUNCTION: # Type: type = match.arg(type) Type = as.integer(type) # Missing x: if (missing(x)) x = (0:10)/10 # Alpha: if (is.null(alpha)) alpha = archmParam(type)$param # Check alpha: check = archmCheck(alpha, type) # Generator: N = length(x) cType = "NA" a = alpha y = x ln = log if (Type == 1) if (alpha == 0) finv2 = exp(-y) else finv2 = finv2 = (1+y*a)^(-(2*a+1)/a)*(a+1) if (Type == 2) if (alpha == 1) cType = "W" else finv2 = y^(-(2*a-1)/a)*(a-1)/a^2 if (Type == 3) if (alpha == 0) cType = "Pi" else if (alpha == 1) Type = "L" else finv2 = -(a-1)*exp(y)*(exp(y)+1)/(exp(y)-1)^3 if (Type == 4) if (alpha == 1) cType = "Pi" else finv2 = exp(-y^(1/a))*(y^(-(2*a-1)/a)*a-y^(-(2*a-1)/a) + y^(-2*(a-1)/a))/a^2 if (Type == 5) if (alpha == 0) cType = "Pi" else finv2 = (-1+exp(a))/(-1+exp(a)-exp(y+a))^2/a*exp(y+a) if (Type == 6) if (alpha == 1) cType = "Pi" else finv2 = (-exp(-(-ln(exp(y)-1)+y)/a) + exp((ln(exp(y)-1)-y+y*a)/a)*a) / (exp(y)-1)^2/a^2 if (Type == 7) if (alpha == 0) cType = "W" else if (alpha == 1) Type = "Pi" else finv2 = -(-exp(y)+a*exp(y))/a/exp(y)+(1-exp(y)+a*exp(y))/a/exp(y) if (Type == 8) if (alpha == 1) cType = "W" else finv2 = 2*a/(1+y*a-y)^3*(a-1) if (Type == 9) if (alpha == 0) cType = "Pi" else finv2 = -1/a^2*(a-exp(y))*exp((y*a-exp(y)+1)/a) if (Type == 10) if (alpha == 0) cType = "Pi" else finv2 = -(exp((y*a+ln(2)-ln(exp(y)+1))/a)*a-exp((2*y*a+ln(2) - ln(exp(y)+1))/a))/(exp(y)+1)^2/a^2 if (Type == 11) if (alpha == 0) cType = "Pi" else finv2 = -exp(y)*((-exp(y)+2)^(-(2*a-1)/a)*exp(y)*a - (-exp(y)+2)^(-(2*a-1)/a)*exp(y)+(-exp(y)+2)^(-(a-1)/a)*a)/a^2 if (Type == 12) if (alpha == 1) cType = "L" else finv2 = (y^(-2*(a-1)/a)+y^(-2*(a-1)/a)*a+y^(-(2*a-1)/a)*a - y^(-(2*a-1)/a))/(y^(1/a)+1)^3/a^2 if (Type == 13) if (alpha == 1) cType = "Pi" else finv2 = exp(-(1+y)^(1/a)+1)*((1+y)^(1/a)*a-(1+y)^(1/a) + (1+y)^(-2*(a-1)/a)+2*(1+y)^(-2*(a-1)/a)*y + (1+y)^(-2*(a-1)/a)*y^2)/a^2/(1+2*y+y^2) if (Type == 14) if (alpha == 1) cType = "L" else finv2 = ((y^(1/a)+1)^(-a-2)*y^(-2*(a-1)/a)*a + (y^(1/a)+1)^(-a-2)*y^(-2*(a-1)/a)+(y^(1/a)+1)^(-a-1) * y^(-(2*a-1)/a)*a-(y^(1/a)+1)^(-a-1)*y^(-(2*a-1)/a))/a if (Type == 15) if (alpha == 1) cType = "L" else finv2 = (a-1)*((-y^(1/a)+1)^(a-2)*y^(-2*(a-1)/a) + (-y^(1/a)+1)^(a-1)*y^(-(2*a-1)/a))/a if (Type == 16) if (alpha == 0) cType = "W" else finv2 = 2*a/(a^2+2*a+2*a*y+1-2*y+y^2)^(3/2) if (Type == 17) if (alpha == -1) cType = "Pi" else finv2 = (2^(-a)-1+exp(y))^(-1/a)*(exp(y*(a+1)/a) - 2^(a+1)*exp(y*(a+1)/a)+exp(y*(a+1)/a)*4^a + exp(1/a*y)*2^(-a)-3*exp(1/a*y)+3*exp(1/a*y)*2^a - exp(1/a*y)*4^a-exp(y*(a+1)/a)*a+2^(a+1) * exp(y*(a+1)/a)*a- exp(y*(2*a+1)/a)*a*2^a - exp(y*(a+1)/a)*a*4^a+exp(y*(2*a+1)/a)*a*4^a)/a^2/(2^(-a)-1 + exp(y))/(1-2^a+exp(y)*2^a)^2 if (Type == 18) finv2 = a*(2+ln(y))/ln(y)^3/y^2 if (Type == 19) if (alpha == 0) cType = "L" else finv2 = a*(2+ln(exp(a)+y))/ln(exp(a)+y)^3/(exp(a)+y)^2 if (type == 20) if (alpha == 0) cType = "Pi" else finv2 = (ln(exp(1)+y)^(-(2*a+1)/a)*a + ln(exp(1)+y)^(-(2*a+1)/a) + ln(exp(1)+y)^(-(a+1)/a)*a)/a^2/(exp(1)+y)^2 if (Type == 21) if (alpha == 1) cType = "W" else finv2 = -(-(1-y)^a+1)^(1/a)*((1-y)^(2*a)-(1-y)^a - a*(1-y)^(2*a)+a*(1-y)^a+(1-y)^(2*a-2)*a - 2*(1-y)^(2*a-2)*a*y+(1-y)^(2*a-2)*a*y^2 -( 1-y)^(2*a-2)+2*(1-y)^(2*a-2)*y-(1-y)^(2*a-2)*y^2) / (-1+y)^2/(-(1-y)^(2*a)+2*(1-y)^a-1) if (Type == 22) if (alpha == 0) cType = "Pi" else finv2 = -(1-sin(y))^(1/a)*(cos(y)^2 + a*sin(y)-2*sin(y)+a-2)/cos(y)^2/a^2 if (cType == "Pi") finv2 = exp(-x) if (cType == "W") finv2 = rep(0, times = N) if (cType == "L") finv2 = 2 / (x+1)^3 # Large x Limit: finv2[which(x>=.Phi0(a, type))] = 0 # Return Value: finv2 } ################################################################################ # FUNCTION: ARCHIMEDEAN DENSITY K GENERATOR: # Kfunc Computes Archimedean Density Kc and its Inverse # KfuncSlider Displays interactively the density and concordance # .Kfunc Computes Density for Archimedean Copulae # .invK Computes Inverse of Density # .invK2 Utility Function # .ALPHA Utility Function # .TAU Utility Function # .RHO Utility Function Kfunc <- function(x, alpha = NULL, type = archmList(), inv = FALSE, lower = 1.0e-8) { # A function implemented by Diethelm Wuertz # Description: # Computes density and its inverse for Archimedean Copulae # FUNCTION: # Type: type = match.arg(type) Type = as.integer(type) # Default alpha: if (is.null(alpha)) alpha = archmParam(type)$param # Check alpha: check = archmCheck(alpha, type) # Density or its inverse: if (!inv) { ans = .Kfunc(x, alpha, type) names(ans)<-"Kfunc" } else { ans = .invK(x, alpha, type, lower) names(ans)<-"invK" } # Add Control Attribute: attr(ans, "control")<-cbind.data.frame(alpha = alpha, type = type, inv = inv, lower = lower, row.names = "") # Return Value: ans } # ------------------------------------------------------------------------------ KfuncSlider <- function(B = 5) { # A function implemented by Diethelm Wuertz # Description: # Displays interactively the density and concordance # FUNCTION: # Graphic Frame: par(mfcol = c(2, 2), cex = 0.7) # Internal Function: refresh.code = function(...) { # Startup Counter: .counter <- getRmetricsOptions(".counter") + 1 setRmetricsOptions(.counter = .counter) if (.counter < 10) return () # Sliders: Copula = as.integer(.sliderMenu(no = 1)) Counter = c(1,2,3,2,4,2,5,2,5,5,6,2,7,2,2,7,4,8,7,7,2,5) No = Counter[Copula] N = .sliderMenu(no = 2) alpha = .sliderMenu(no = No+2) # Skip: if (Copula == 13 & alpha == 0) return(invisible()) # Do we have a strict Copula? strict = c( "Yes","No","Yes","Yes","Yes","Yes","No","No","Yes","Yes", "No","Yes","Yes","Yes","No","Yes","Yes","No","Yes","Yes", "No","Yes")[Copula] if (alpha < 0 & Copula == 1) strict[1] = "No" if (alpha == 0 & Copula == 16) strict[16] = "No" # What is the Range? RANGE = c( "-1|Inf", "1|Inf", "-1|1", "-Inf|inf", "0|1", "0|0.5", "0|Inf", "2|Inf")[No] # Which one is the Limit Copula? limitTitle = rep("NA", times = 22) if (alpha == -1) limitTitle = c( "W ", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "Pi", "NA", "NA", "NA", "NA", "NA") if (alpha == 0) limitTitle = c( "Pi", "NA", "Pi", "NA", "Pi", "NA", "W ", "NA", "Pi", "Pi", "Pi", "NA", "NA", "NA", "NA", "W ", "NA", "NA", "L ", "Pi", "NA", "Pi") if (alpha == 1) limitTitle = c( "L ", "W ", "L ", "Pi", "NA", "Pi", "Pi", "W ", "NA", "NA", "NA", "L ", "Pi", "L ", "W ", "NA", "NA", "NA", "NA", "NA", "W ", "NA") limitTitle = limitTitle[Copula] if (limitTitle == "NA") { limitTitle = " " } else { limitTitle = paste(" Copula = ", limitTitle[1]) } # Plot 1 - Kfunc: x = (0:N)/N y = .Kfunc(x = x, alpha = alpha, type = as.character(Copula)) plot(x = x, y = y, ylim = c(0, 1), type = "l", xlab = "t", ylab = "K") title(main = paste("K - Archimedean Copula No:", as.character(Copula), "\nalpha = ", as.character(alpha), " Strict = ", strict, limitTitle)) if (N < 100) points(x = x, y = y, pch = 19, cex = 0.5) y10 = .Kfunc(x = (0:10)/10, alpha = alpha, type = as.character(Copula)) invK10 = .invK2(y10, alpha = alpha, type = as.character(Copula)) points(invK10, y10, col = "red") text(x = 0.8, y = 0.075, labels = "Test: invK[invK]", col = "red") # Plot 2 - archmTau: tau = .archmTau(alpha = alpha, type = as.character(Copula)) rho = approx(.ALPHA[, Copula], .RHO[, Copula], xout = alpha)$y plot(x = .ALPHA[, Copula], y = .TAU[, Copula], ylim = c(-1, 1), type = "l", col = "red", xlab = paste("alpha: ", RANGE, sep = ""), ylab = "Tau") # points(x = .ALPHA[, Copula], y = .TAU[, Copula], pch = 19, cex = 0.5) lines(x = .ALPHA[, Copula], y = .RHO[, Copula], col = "blue") # points(x = .ALPHA[, Copula], y = .RHO[, Copula], pch = 19, cex = 0.5) points(x = alpha, y = tau, pch = 19, col = "red") abline(h = .archmTauRange(type = as.character(Copula))[1], lty =3, col = "steelblue") abline(h = .archmTauRange(type = as.character(Copula))[2], lty =3, col = "steelblue") points(x = alpha, y = rho, col = "blue", pch = 19) mtext("rho ", 4, col = "blue", cex = 0.75) mtext(" tau", 4, col = "red ", cex = 0.75) title(main = paste("Concordance Measures", "\ntau = ", as.character(round(tau, digits = 2)), "rho = ", as.character(round(rho, digits = 2)) ) ) plot(x = y, y = x, xlim = c(0, 1), type = "l", xlab = "K", ylab = "t") title(main = "Inverse K") # Plot 3 - lambda U: # xTail = 1 - (1/2)^(1:20) # Tail = .archmTail(alpha = alpha, type = as.character(Copula)) # plot(x = xTail, y = Tail$lambdaU.Cuv, col = "blue", # xlim = c(0, 1), ylim = c(0, 1), main = "Tail Dependence") # points(x = xTail, y = Tail$lambdaU.Phi, col = "red", pch = 3) # Rho: # Rho = NULL # for ( a in Alpha) # Rho = c(Rho, archmRho(alpha = a, type = as.character(Copula))) # lines(x = Alpha, y = Rho, type = "l", col = "blue") # rho = archmRho(alpha = alpha, type = as.character(Copula)) # points(x = alpha, y = rho, col = "red", pty = 19) # plot(rnorm(100)) # plot(rnorm(100)) # Reset Frame: par(mfcol = c(2, 2), cex = 0.7) } # Open Slider Menu: setRmetricsOptions(.counter = 0) C1 = "1: [-1,Inf]" C2 = "2-4-6-8-12-14-15-21: [1,Inf)" C3 = "3: [-1,1)" C4 = "5-17: (-Inf,Inf)|{0}" C5 = "7-9-10-22: (0,1]" C6 = "11: (0, 1/2]" C7 = "13-16-19-20: (0,Inf)" C8 = "18: [2, Inf)" C = c( C1, C2, C3, C4, C5, C6, C7, C8 ) L = c( -1, 1, -1, -B, 0, 0, 0, 2 ) U = c( B, 5*B, 1, 5*B, 1, 0.5, B, B ) A = c( 0.5, 2, 0.5, 1, 0.5, 0.2, 1, 3 ) V = rep(0.01, 20) .sliderMenu(refresh.code, names = c("Copula", "N", C), minima = c( 1, 10, L), maxima = c( 22, 1000, U), resolutions = c( 1, 10, V), starts = c( 1, 100, A)) } # ------------------------------------------------------------------------------ .Kfunc <- function(x, alpha = NULL, type = archmList()) { # A function implemented by Diethelm Wuertz # Description: # Computes Density for Archimedean Copulae # Arguments: # x - a numeric vector # FUNCTION: # Type: type = match.arg(type) Type = as.integer(type) # Missing x: if (missing(x)) x = (0:10)/10 # Alpha: if (is.null(alpha)) alpha = archmParam(type)$param # Check alpha: check = archmCheck(alpha, type) # Density: Kfunc = x - .Phi(x, alpha, type) / .PhiFirstDer(x, alpha, type) # Take care from divergencies: Kfunc[is.na(Kfunc)] = 0 Kfunc[x == 1] = 1 # Return Value: Kfunc } # ------------------------------------------------------------------------------ .invK <- function(x, alpha = NULL, type = archmList(), lower = 1.0e-8) { # A function implemented by Diethelm Wuertz # Description: # Computes Inverse of Density for Archimedean Copulae # FUNCTION: # Type: type = match.arg(type) Type = as.integer(type) # Alpha: if (is.null(alpha)) alpha = archmParam(type)$param # Check alpha: check = archmCheck(alpha, type) # Compute Inverse: .fKC = function(x, p, alpha, type) { .Kfunc (x, alpha, type) - p } p = x z = NULL for (P in p) { if (P > 1 - lower/2) { res = 1 } else if (P < .Kfunc(0, alpha, type) + lower/2 ) { res = 0 } else { res = uniroot(.fKC, c(lower, 1), p = P, alpha = alpha, type = type)$root } z = c(z, res) } # Return Value: z } # ------------------------------------------------------------------------------ .invK2 <- function(x, alpha, type = archmList()) { # A function implemented by Diethelm Wuertz # Description: # Computes from tabulated values # FUNCTION: # Type: type = match.arg(type) Type = as.integer(type) # Tabulated Values: iK = NULL for (i in 1:length(x)) { Ord = order(abs(.Kfunc((0:1000)/1000, alpha, type)-x[i]))[1]/1000 iK = c(iK, Ord) } # Return Value: iK } # ------------------------------------------------------------------------------ .makeConcordanceTable <- function(B = 5, dump = FALSE) { # A function implemented by Diethelm Wuertz # Make Table: Counter <- c(1,2,3,2,4,2,5,2,5,5,6,2,7,2,2,7,4,8,7,7,2,5) L = c( -1, +1, -1, -5*B, 0, 0, 0, 2 ) U = c( B, 5*B, 1, 5*B, 1, 0.5, B, B ) Tau = Alpha = Rho = NULL for (i in 1:22) { print(i) No = Counter[i] lower = L[No] upper = U[No] alpha = seq(lower, upper, length = 25) Alpha = cbind(Alpha, alpha) tau = archmTau(alpha = alpha, type = i) rho = archmRho(alpha = alpha, type = i) Tau = cbind(Tau, tau) Rho = cbind(Rho, rho) } .ALPHA = data.frame(Alpha) .TAU = data.frame(Tau) .RHO = data.frame(Rho) colnames(.ALPHA) = colnames(.TAU) = colnames(.RHO) = as.character(1:22) # Dump: if (dump) { dump(".ALPHA", "alpha.R") dump(".TAU", "tau.R") dump(".RHO", "rho.R") } # Return Value: list(ALPHA = .ALPHA, TAU = .TAU, RHO = .RHO) } # ------------------------------------------------------------------------------ ".ALPHA" <- structure(list( "1" = c(-1, -0.75, -0.5, -0.25, 0, 0.25, 0.5, 0.75, 1, 1.25, 1.5, 1.75, 2, 2.25, 2.5, 2.75, 3, 3.25, 3.5, 3.75, 4, 4.25, 4.5, 4.75, 5), "2" = c(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25), "3" = c(-1, -0.916666666666667, -0.833333333333333, -0.75, -0.666666666666667, -0.583333333333333, -0.5, -0.416666666666667, -0.333333333333333, -0.25, -0.166666666666667, -0.0833333333333334, 0, 0.0833333333333333, 0.166666666666667, 0.25, 0.333333333333333, 0.416666666666667, 0.5, 0.583333333333333, 0.666666666666667, 0.75, 0.833333333333333, 0.916666666666667, 1), "4" = c(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25), "5" = c(-25, -22.9166666666667, -20.8333333333333, -18.75, -16.6666666666667, -14.5833333333333, -12.5, -10.4166666666667, -8.33333333333333, -6.25, -4.16666666666666, -2.08333333333333, 0, 2.08333333333334, 4.16666666666667, 6.25, 8.33333333333334, 10.4166666666667, 12.5, 14.5833333333333, 16.6666666666667, 18.75, 20.8333333333333, 22.9166666666667, 25), "6" = c(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25), "7" = c(0, 0.0416666666666667, 0.0833333333333333, 0.125, 0.166666666666667, 0.208333333333333, 0.25, 0.291666666666667, 0.333333333333333, 0.375, 0.416666666666667, 0.458333333333333, 0.5, 0.541666666666667, 0.583333333333333, 0.625, 0.666666666666667, 0.708333333333333, 0.75, 0.791666666666667, 0.833333333333333, 0.875, 0.916666666666667, 0.958333333333333, 1), "8" = c(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25), "9" = c(0, 0.0416666666666667, 0.0833333333333333, 0.125, 0.166666666666667, 0.208333333333333, 0.25, 0.291666666666667, 0.333333333333333, 0.375, 0.416666666666667, 0.458333333333333, 0.5, 0.541666666666667, 0.583333333333333, 0.625, 0.666666666666667, 0.708333333333333, 0.75, 0.791666666666667, 0.833333333333333, 0.875, 0.916666666666667, 0.958333333333333, 1), "10" = c(0, 0.0416666666666667, 0.0833333333333333, 0.125, 0.166666666666667, 0.208333333333333, 0.25, 0.291666666666667, 0.333333333333333, 0.375, 0.416666666666667, 0.458333333333333, 0.5, 0.541666666666667, 0.583333333333333, 0.625, 0.666666666666667, 0.708333333333333, 0.75, 0.791666666666667, 0.833333333333333, 0.875, 0.916666666666667, 0.958333333333333, 1), "11" = c(0, 0.0208333333333333, 0.0416666666666667, 0.0625, 0.0833333333333333, 0.104166666666667, 0.125, 0.145833333333333, 0.166666666666667, 0.1875, 0.208333333333333, 0.229166666666667, 0.25, 0.270833333333333, 0.291666666666667, 0.3125, 0.333333333333333, 0.354166666666667, 0.375, 0.395833333333333, 0.416666666666667, 0.4375, 0.458333333333333, 0.479166666666667, 0.5), "12" = c(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25), "13" = c(0, 0.208333333333333, 0.416666666666667, 0.625, 0.833333333333333, 1.04166666666667, 1.25, 1.45833333333333, 1.66666666666667, 1.875, 2.08333333333333, 2.29166666666667, 2.5, 2.70833333333333, 2.91666666666667, 3.125, 3.33333333333333, 3.54166666666667, 3.75, 3.95833333333333, 4.16666666666667, 4.375, 4.58333333333333, 4.79166666666667, 5), "14" = c(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25), "15" = c(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25), "16" = c(0, 0.208333333333333, 0.416666666666667, 0.625, 0.833333333333333, 1.04166666666667, 1.25, 1.45833333333333, 1.66666666666667, 1.875, 2.08333333333333, 2.29166666666667, 2.5, 2.70833333333333, 2.91666666666667, 3.125, 3.33333333333333, 3.54166666666667, 3.75, 3.95833333333333, 4.16666666666667, 4.375, 4.58333333333333, 4.79166666666667, 5), "17" = c(-25, -22.9166666666667, -20.8333333333333, -18.75, -16.6666666666667, -14.5833333333333, -12.5, -10.4166666666667, -8.33333333333333, -6.25, -4.16666666666666, -2.08333333333333, 0, 2.08333333333334, 4.16666666666667, 6.25, 8.33333333333334, 10.4166666666667, 12.5, 14.5833333333333, 16.6666666666667, 18.75, 20.8333333333333, 22.9166666666667, 25), "18" = c(2, 2.125, 2.25, 2.375, 2.5, 2.625, 2.75, 2.875, 3, 3.125, 3.25, 3.375, 3.5, 3.625, 3.75, 3.875, 4, 4.125, 4.25, 4.375, 4.5, 4.625, 4.75, 4.875, 5), "19" = c(0, 0.208333333333333, 0.416666666666667, 0.625, 0.833333333333333, 1.04166666666667, 1.25, 1.45833333333333, 1.66666666666667, 1.875, 2.08333333333333, 2.29166666666667, 2.5, 2.70833333333333, 2.91666666666667, 3.125, 3.33333333333333, 3.54166666666667, 3.75, 3.95833333333333, 4.16666666666667, 4.375, 4.58333333333333, 4.79166666666667, 5), "20" = c(0, 0.208333333333333, 0.416666666666667, 0.625, 0.833333333333333, 1.04166666666667, 1.25, 1.45833333333333, 1.66666666666667, 1.875, 2.08333333333333, 2.29166666666667, 2.5, 2.70833333333333, 2.91666666666667, 3.125, 3.33333333333333, 3.54166666666667, 3.75, 3.95833333333333, 4.16666666666667, 4.375, 4.58333333333333, 4.79166666666667, 5), "21" = c(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25), "22" = c(0, 0.0416666666666667, 0.0833333333333333, 0.125, 0.166666666666667, 0.208333333333333, 0.25, 0.291666666666667, 0.333333333333333, 0.375, 0.416666666666667, 0.458333333333333, 0.5, 0.541666666666667, 0.583333333333333, 0.625, 0.666666666666667, 0.708333333333333, 0.75, 0.791666666666667, 0.833333333333333, 0.875, 0.916666666666667, 0.958333333333333, 1)), .Names = c("1", "2", "3", "4", "5", "6", "7", "8", "9", "10", "11", "12", "13", "14", "15", "16", "17", "18", "19", "20", "21", "22"), row.names = c("1", "2", "3", "4", "5", "6", "7", "8", "9", "10", "11", "12", "13", "14", "15", "16", "17", "18", "19", "20", "21", "22", "23", "24", "25"), class = "data.frame") # ------------------------------------------------------------------------------ ".TAU" <- structure(list( "1" = c(-1, -0.6, -0.333333333333333, -0.142857142857143, 0, 0.111111111111111, 0.2, 0.272727272727273, 0.333333333333333, 0.384615384615385, 0.428571428571429, 0.466666666666667, 0.5, 0.529411764705882, 0.555555555555556, 0.578947368421053, 0.6, 0.619047619047619, 0.636363636363636, 0.652173913043478, 0.666666666666667, 0.68, 0.692307692307692, 0.703703703703704, 0.714285714285714 ), "2" = c(-1, 0, 0.333333333333333, 0.5, 0.6, 0.666666666666667, 0.714285714285714, 0.75, 0.777777777777778, 0.8, 0.818181818181818, 0.833333333333333, 0.846153846153846, 0.857142857142857, 0.866666666666667, 0.875, 0.88235294117647, 0.888888888888889, 0.894736842105263, 0.9, 0.904761904761905, 0.909090909090909, 0.91304347826087, 0.916666666666667, 0.92), "3" = c(-0.181725814826518, -0.168930151452714, -0.155798192853549, -0.142309156210049, -0.128440099024957, -0.114165590552606, -0.0994573153156502, -0.0842835904937131, -0.068608772818993, -0.0523925219034918, -0.0355888743571007, -0.0181450645517658, 0, 0.0189177438301371, 0.0386926132325796, 0.0594257680440222, 0.0812402882884418, 0.104288760957381, 0.128764787039966, 0.154921339236023, 0.183102048111355, 0.21379958230518, 0.247780252512751, 0.286418218456134, 0.333333333333333), "4" = c(0, 0.5, 0.666666666666667, 0.75, 0.8, 0.833333333333333, 0.857142857142857, 0.875, 0.888888888888889, 0.9, 0.909090909090909, 0.916666666666667, 0.923076923076923, 0.928571428571429, 0.933333333333333, 0.9375, 0.941176470588235, 0.944444444444444, 0.947368421052632, 0.95, 0.952380952380952, 0.954545454545455, 0.956521739130435, 0.958333333333333, 0.96), "5" = c(-0.85052757802554, -0.837983233335134, -0.823159712179848, -0.805382359321779, -0.78368703586404, -0.756652338202137, -0.722109024177686, -0.676626253020113, -0.61461896491917, -0.527006789744252, -0.400406496234527, -0.222118698154441, 0, 0.222118698154449, 0.400406496234539, 0.527006789744276, 0.614618964919029, 0.676626253020132, 0.722109024177453, 0.756652338200781, 0.783687035871101, 0.805382359356256, 0.823159712267863, 0.837983231749698, 0.850527554271354), "6" = c(0, 0.355065933151777, 0.517962498229816, 0.613705638974404, 0.677220914237255, 0.722592092430507, 0.756685017415291, 0.783274098241282, 0.80461673005689, 0.822148933158253, 0.836832638206725, 0.84932812611196, 0.860110789048376, 0.869526200860125, 0.877832575748863, 0.885224248904, 0.891855111133839, 0.897842192832803, 0.903279485909824, 0.90824351995753, 0.912795085448852, 0.91698501728904, 0.920858299365945, 0.924445190119985, 0.927779794217425), "7" = c(1, 0.971927944913947, 0.943246768509585, 0.913923522796783, 0.88392216030227, 0.853203097878133, 0.821722695867944, 0.789432631089395, 0.756279135134686, 0.722202059745913, 0.687133717127867, 0.65099742284623, 0.613705638880109, 0.575157568479307, 0.535235982291939, 0.493802937831557, 0.450693855665945, 0.40570906309108, 0.358601253084469, 0.309055967047944, 0.256659242461756, 0.200839120747762, 0.140745344631603, 0.0749411953484011, 0), "8" = c(-1, -0.333333333333333, -0.111111111111111, 0, 0.0666666666666667, 0.111111111111111, 0.142857142857143, 0.166666666666667, 0.185185185185185, 0.2, 0.212121212121212, 0.222222222222222, 0.230769230769231, 0.238095238095238, 0.244444444444444, 0.25, 0.254901960784314, 0.259259259259259, 0.263157894736842, 0.266666666666667, 0.26984126984127, 0.272727272727273, 0.275362318840580, 0.277777777777778, 0.28), "9" = c(0, -0.0204163452169608, -0.0400596555238257, -0.0590081036085306, -0.0773261331388824, -0.0950679058715638, -0.112279639253442, -0.129001262402105, -0.145267629233813, -0.161109431296128, -0.176553899922191, -0.191625356399165, -0.206345649900960, -0.220734510872628, -0.234809839618285, -0.24858794447726, -0.262083740255211, -0.275310914946985, -0.288282070892981, -0.301008845122611, -0.313502012606631, -0.325771575362601, -0.337826839765094, -0.349676483955214, -0.361328616888101), "10" = c(0, -0.0196066744396921, -0.0370221472721557, -0.0525703541709941, -0.0665070136005856, -0.0790393052012712, -0.0903383149316412, -0.100547418134766, -0.109788190716896, -0.118164725554978, -0.125766872846962, -0.132672728007605, -0.138950577833938, -0.144660447061511, -0.149855344023087, -0.154582275706178, -0.158883083359664, -0.162795136572255, -0.166351914405464, -0.16958349544035, -0.172516973673804, -0.175176813539516, -0.177585154568996, -0.179762074101597, -0.181725814826518), "11" = c(0, -0.0208398943709387, -0.0417175967562695, -0.0626672066307008, -0.083719725295789, -0.104903822366714, -0.126246401393688, -0.147773031839223, -0.169508288800322, -0.191476027240807, -0.213699608737601, -0.236202093256811, -0.259006404912340, -0.282135478276679, -0.305612390180847, -0.329460480799121, -0.353703467003579, -0.378365550391214, -0.403471521964720, -0.429046865142757, -0.455117858555391, -0.481711679925032, -0.50885651222745, -0.536581653261374, -0.564917629721708), "12" = c(0.333333333333333, 0.666666666666667, 0.777777777777778, 0.833333333333333, 0.866666666666667, 0.888888888888889, 0.904761904761905, 0.916666666666667, 0.925925925925926, 0.933333333333333, 0.93939393939394, 0.944444444444444, 0.948717948717949, 0.952380952380952, 0.955555555555556, 0.958333333333333, 0.96078431372549, 0.962962962962963, 0.964912280701754, 0.966666666666667, 0.968253968253968, 0.96969696969697, 0.971014492753623, 0.972222222222222, 0.973333333333333), "13" = c(-0.3613289, -0.269528030161219, -0.187585190523704, -0.114164377378166, -0.048139718340646, 0.0114414518639374, 0.0653882965033201, 0.114390646561491, 0.159038737349337, 0.199839382405940, 0.237229274320303, 0.271585960700895, 0.303236932556452, 0.332467174993497, 0.359525461142416, 0.384629615561405, 0.407970929923072, 0.42971787915222, 0.450019258484065, 0.469006839692804, 0.486797626862941, 0.503495777648588, 0.519194244288641, 0.533976179166497, 0.547916141985897), "14" = c(0.333333333333333, 0.6, 0.714285714285714, 0.777777777777778, 0.818181818181818, 0.846153846153846, 0.866666666666667, 0.88235294117647, 0.894736842105263, 0.904761904761905, 0.91304347826087, 0.92, 0.925925925925926, 0.93103448275862, 0.935483870967742, 0.93939393939394, 0.942857142857143, 0.945945945945946, 0.948717948717949, 0.951219512195122, 0.953488372093023, 0.955555555555556, 0.957446808510638, 0.959183673469388, 0.96078431372549), "15" = c(-1, 0.333333333333333, 0.6, 0.714285714285714, 0.777777777777778, 0.818181818181818, 0.846153846153846, 0.866666666666667, 0.88235294117647, 0.894736842105263, 0.904761904761905, 0.91304347826087, 0.92, 0.925925925925926, 0.93103448275862, 0.935483870967742, 0.93939393939394, 0.942857142857143, 0.945945945945946, 0.948717948717949, 0.951219512195122, 0.953488372093023, 0.955555555555556, 0.957446808510638, 0.959183673469388), "16" = c(-1, 0.0199469096156091, 0.129575836560517, 0.180662881950351, 0.210821233719316, 0.230868290892863, 0.245206353296857, 0.255989120788036, 0.264401763304115, 0.271152717969063, 0.276692429117510, 0.281321400174802, 0.285247984614676, 0.288621292351708, 0.291550902234041, 0.294119177987248, 0.296389240808115, 0.298410289410793, 0.300221244635643, 0.301853304387547, 0.303331771457812, 0.304677385016165, 0.305907306382662, 0.307035859574841, 0.308075095038758), "17" = c(-0.505322479883461, -0.495828713697966, -0.48454639378008, -0.470935203584076, -0.454226630515362, -0.433303941761343, -0.406516652894873, -0.371413076160088, -0.324429660012302, -0.26078346047423, -0.175313467887867, -0.0654880362471264, 3, 0.198425450290705, 0.322606327311886, 0.426990238062425, 0.510371695749375, 0.575835676725875, 0.627386508234144, 0.668494514582698, 0.701798032118806, 0.729213683422655, 0.752120712677402, 0.771518248976997, 0.78813985427463), "18" = c(0.333333333333333, 0.372549019607843, 0.407407407407407, 0.43859649122807, 0.466666666666667, 0.492063492063492, 0.515151515151515, 0.536231884057971, 0.555555555555556, 0.573333333333333, 0.58974358974359, 0.604938271604938, 0.619047619047619, 0.632183908045977, 0.644444444444444, 0.655913978494624, 0.666666666666667, 0.676767676767677, 0.686274509803922, 0.695238095238095, 0.703703703703704, 0.711711711711712, 0.719298245614035, 0.726495726495726, 0.733333333333333), "19" = c(0, 0.429836470415013, 0.492561142661991, 0.539699842175544, 0.577243238619945, 0.608200347675897, 0.634340746150618, 0.656827513885057, 0.676426663266239, 0.693706733577166, 0.709084640531406, 0.722877931761809, 0.735333844361156, 0.746648476889695, 0.756979782729611, 0.766456689701118, 0.775185755847842, 0.783255888758933, 0.790741999213658, 0.797707696363886, 0.80420742554753, 0.810288035370101, 0.815990188618369, 0.821349301247486, 0.826396408325272), "20" = c(0.333333333333333, 0.187581702849446, 0.336923464258114, 0.453621153661734, 0.544347004922251, 0.615306486593428, 0.671462346739915, 0.716591196240161, 0.753556906539465, 0.784548776018356, 0.811245341187264, 0.834925230324345, 0.856550987713366, 0.87682562788058, 0.896293707460173, 0.915293066771852, 0.934084281673088, 0.952832982671359, 0.97164182521641, 0.99056793780414, 1.00963608457645, 1.02884861875661, 1.04819318064612, 1.06764664223826, 1.0871818991606), "21" = c(-0.9999999996, 0.227411277761033, 0.475707247837903, 0.594420704044238, 0.666780283574186, 0.716296479239256, 0.752597708588034, 0.780474107458171, 0.80263551556664, 0.820709018127606, 0.835799583394556, 0.848581734688507, 0.859631891238008, 0.869228393597159, 0.877745364348898, 0.885267593021253, 0.8921031172938, 0.89816522529609, 0.903767761397344, 0.908803416914886, 0.913503328379058, 0.917746442778645, 0.921749156268669, 0.925374342563027, 0.92882540945077), "22" = c(8.88178419700125e-16, -0.0204403642205317, -0.0402325966459149, -0.0595398315924127, -0.0784852878388032, -0.09716610551268, -0.115661428244375, -0.134037489701166, -0.152350993933844, -0.170651459100329, -0.18898289917049, -0.207385066034675, -0.225894390250444, -0.244544709719205, -0.263367845858735, -0.282394068127122, -0.301652475612564, -0.321171316316645, -0.340978259249309, -0.361100630626295, -0.381565622756077, -0.402400482266088, -0.423632682913976, -0.445290087203517, -0.467401100271068)), .Names = c("1", "2", "3", "4", "5", "6", "7", "8", "9", "10", "11", "12", "13", "14", "15", "16", "17", "18", "19", "20", "21", "22"), row.names = c("1", "2", "3", "4", "5", "6", "7", "8", "9", "10", "11", "12", "13", "14", "15", "16", "17", "18", "19", "20", "21", "22", "23", "24", "25"), class = "data.frame") # ------------------------------------------------------------------------------ ".RHO" <- structure(list( "1" = c(-1.00148148148148, -0.738747613322986, -0.466622048681987, -0.211687707079451, 0, 0.165652020595619, 0.294857841987463, 0.396806275669875, 0.478390117460797, 0.544587799346395, 0.598994031361846, 0.644231561135091, 0.682240753560612, 0.714478294671625, 0.742053406185035, 0.765822053649082, 0.786452951364207, 0.80447447147138, 0.820308460074897, 0.83429494974631, 0.846710452420334, 0.85778166343474, 0.867695842924806, 0.876608762194626, 0.884650845307784), "2" = c(-1.00148148148148, 0.141567825309872, 0.533448886027939, 0.708244460527527, 0.800738510405266, 0.855438151990562, 0.89038551287057, 0.913977650156251, 0.930840822487669, 0.943140720229384, 0.952367340916965, 0.959636846016786, 0.965337805120064, 0.969884351339425, 0.973637657583298, 0.976727483348096, 0.979298582357153, 0.98146084822125, 0.983296560480555, 0.984868310083549, 0.986245587058835, 0.987459252328268, 0.988521705438795, 0.989457189777394, 0.990285276373145), "3" = c(-0.271064557642169, -0.252157028402899, -0.232714526887962, -0.212705548849901, -0.19209555265805, -0.170846533523001, -0.148916516723668, -0.12625894982673, -0.102821967656877, -0.078547495149129, -0.0533701410712804, -0.0272158181938728, 1.38263885937115e-18, 0.0283745141601889, 0.0580205123349336, 0.0890702417932126, 0.121680672987631, 0.156040852661039, 0.192382519137300, 0.230996069414554, 0.272255880785214, 0.316663434022027, 0.36492869505212, 0.418151365908671, 0.478390117460797), "4" = c(1.38263885937115e-18, 0.682189978639204, 0.848820654347913, 0.912515206140176, 0.943205695413621, 0.960245155358946, 0.970657019434397, 0.977474770619668, 0.982178751195054, 0.985559960479453, 0.98807177913133, 0.989989026203176, 0.99148606893177, 0.99267782385585, 0.993642497101149, 0.994434794399345, 0.99509390407114, 0.995648488592752, 0.996119899908012, 0.996524305455528, 0.99687412690816, 0.997179034157432, 0.99744664490479, 0.997683025382027, 0.997893054234396), "5" = c(-0.972111584358926, -0.967209491068637, -0.960903114161494, -0.952607108183223, -0.941402673140619, -0.925789337989117, -0.903206982408158, -0.869086491837814, -0.814968529644537, -0.725140930480804, -0.573066256464247, -0.328659597722, 1.38263885937115e-18, 0.328659597722, 0.573066256464246, 0.725140930480804, 0.814968529644528, 0.86908649183787, 0.903206982408021, 0.92578933798917, 0.941402673149305, 0.95260710822185, 0.960903114203512, 0.967209491448638, 0.972111584081945), "6" = c(1.38263885937115e-18, 0.504193253656214, 0.700093384009142, 0.798178467968907, 0.854636457142996, 0.890208596051013, 0.914104060707307, 0.930945457506372, 0.943268127871861, 0.952561541134428, 0.95968871558049, 0.966247582643763, 0.970782114931405, 0.976498903835584, 0.979560788569006, 0.98205552457824, 0.993861933959956, 0.99558219645679, 1.00597796784080, 1.00765676774247, 1.03633645236535, 1.03732862637663, 1.03805548919961, 1.05932394767550, 1.06079424267615), "7" = c(-1.00148148148148, -0.979072702331951, -0.956663923182448, -0.934255144032922, -0.910476817558297, -0.885980795610422, -0.86087901234568, -0.834111385459534, -0.806575582990396, -0.777481481481482, -0.747489711934157, -0.715582990397804, -0.682232098765431, -0.646978326474623, -0.60966803840878, -0.570271604938272, -0.528215089163238, -0.482955281207133, -0.434469135802469, -0.381630727023320, -0.323950617283951, -0.259980246913580, -0.187865020576132, -0.104024142661180, 1.38263885937115e-18), "8" = c(-1.00148148148148, -0.382286405036925, -0.114601585715482, 0.0310996982933278, 0.121547108159812, 0.182711347208507, 0.226564943368020, 0.259498634290694, 0.28500277910381, 0.305383082451978, 0.321951896975906, 0.335684240420725, 0.347297689031008, 0.35716340065043, 0.365682214112401, 0.373072635634355, 0.379610561045101, 0.385393549400538, 0.390535446981844, 0.395136786179741, 0.399301204243857, 0.403072768984719, 0.406501170036244, 0.409631031685417, 0.412499583816874), "9" = c(0, -0.0306009955864517, -0.0600171715566712, -0.0883435022143309, -0.115662851324462, -0.14204808424762, -0.167563722488530, -0.192267256145817, -0.216210197252217, -0.239438934387163, -0.261995433039874, -0.283917814885177, -0.305240840989756, -0.325996318037027, -0.346213442292882, -0.365919092784125, -0.385138082715462, -0.403893376291347, -0.422206276681155, -0.440096589759673, -0.457582767389748, -0.474682033331841, -0.4914104943232, -0.507783238435509, -0.523814422470025), "10" = c(0, -0.029390926055108, -0.0554838410175942, -0.0787567884244303, -0.0995948147001642, -0.118312849424028, -0.135171965480742, -0.150391128987132, -0.164155854619207, -0.176624701885803, -0.187934236009538, -0.198202876118343, -0.207533922658104, -0.216017969401489, -0.223734847121171, -0.230755205988202, -0.237141815823774, -0.24295064350982, -0.248231752581214, -0.253030059585575, -0.257385974070141, -0.261335943265486, -0.264912918148678, -0.268146754209015, -0.271064557642169), "11" = c(0, -0.0312337307463261, -0.0624885635341056, -0.0937774571924054, -0.125109119631511, -0.156488211337586, -0.187915529826987, -0.219388201730151, -0.250899897834131, -0.282441141124533, -0.313999597626781, -0.345560474009285, -0.377106883941072, -0.408620285268396, -0.440080745221534, -0.471467680629385, -0.502759810642414, -0.533935835408547, -0.564973896022694, -0.595854502689236, -0.626555877382724, -0.657058974751787, -0.687347683323, -0.717399152001416, -0.747202834006994), "12" = c(0.478390117460797, 0.847457484412861, 0.929514118116192, 0.959770189940577, 0.974091289816988, 0.98196494553155, 0.98674930920016, 0.989872618006014, 0.992024786623663, 0.99357184100672, 0.994722476491513, 0.995602679183581, 0.99629212083331, 0.996843164325584, 0.99729136172679, 0.99766153224032, 0.997971424587865, 0.998234001133303, 0.998458905801764, 0.998653432689402, 0.998823180355318, 0.998972503148868, 0.99910482845359, 0.99922288351134, 0.999328860123071), "13" = c(8.60444444444445, -0.396927340010433, -0.279041044592502, -0.170790656731972, -0.0721889092723266, 0.0171559644885065, 0.0978612488308676, 0.170645482690321, 0.236250585187531, 0.295396788789730, 0.34875879445432, 0.396954947814539, 0.440544088483541, 0.480026728592929, 0.515848521579894, 0.548404801961588, 0.578045482558421, 0.605079904444685, 0.629781421965416, 0.652391617354311, 0.673124105746233, 0.692167929492244, 0.709690561612045, 0.725840548723069, 0.740749828053321), "14" = c(0.478390117460797, 0.78697038487367, 0.88669651583035, 0.930158273783357, 0.952781313104883, 0.966001646844378, 0.97438037870724, 0.98001921761715, 0.983993663292466, 0.98689971728531, 0.989089008338032, 0.990779746538743, 0.992113107410875, 0.99318367420424, 0.99405672549771, 0.994778481699574, 0.995382405409204, 0.995893200807138, 0.996329424259493, 0.996705230895822, 0.9970315690086, 0.997317013020675, 0.99756835474172, 0.997791029818825, 0.997989429828517), "15" = c(-1.00148148148148, 0.483330421553014, 0.788592827249555, 0.887213491121673, 0.930351139068034, 0.952863855394297, 0.966040941166183, 0.974400661352683, 0.980030344652669, 0.984000050201677, 0.98690350529195, 0.989091305340107, 0.990781156959334, 0.992113975575947, 0.993184203332592, 0.99405703905789, 0.994778656516628, 0.995382490232112, 0.99589322707115, 0.996329412502773, 0.996705194678632, 0.9970315173572, 0.997316951978555, 0.997568288369395, 0.997790960846676), "16" = c(-1.00148148148148, 0.0399918107572716, 0.196922447742505, 0.269217972641498, 0.311479910536255, 0.339361834072764, 0.359187127162052, 0.374027186155748, 0.385561510047341, 0.394788531585647, 0.402340078994373, 0.408635928417183, 0.41396608392397, 0.418537431930041, 0.422501583532575, 0.425972210130218, 0.429036230512499, 0.431761254762484, 0.434200670669304, 0.436397200953502, 0.438385442597004, 0.440193712932073, 0.441845413865275, 0.443360054973381, 0.444754031079707), "17" = c(-0.644683937053512, -0.638242233699325, -0.63002248705626, -0.619327391403488, -0.605102498262373, -0.585717699732245, -0.558611529498344, -0.519748499835421, -0.462935375218991, -0.379451494373527, -0.259494676315209, -0.0980201065759068, -2.86814814814815, 0.294555695013013, 0.469764827999549, 0.606508141811551, 0.705924049580753, 0.776198676767287, 0.825867405611722, 0.86149149285161, 0.887580315101809, 0.907115201815617, 0.922057497657996, 0.933711847666972, 0.942961892529542), "18" = c(0.579165030761005, 0.612486124687689, 0.641987920637447, 0.668204867084776, 0.691471975626513, 0.712672417787934, 0.731485428240074, 0.748541425177017, 0.763998843765579, 0.7781439158238, 0.79107000000924, 0.802825120690881, 0.81347401988651, 0.823349095595444, 0.832637848646758, 0.841114775574677, 0.848922542682376, 0.85620758378877, 0.862952434000152, 0.869158594153996, 0.87492608635104, 0.880415774029804, 0.885630004240057, 0.890455816493047, 0.894963682434538), "19" = c(0.478390117460797, 0.593310952911897, 0.663998561233565, 0.71419945722106, 0.752174890526936, 0.782049472476609, 0.806205285404551, 0.826145083754451, 0.842875473608911, 0.857101027367348, 0.869331955302181, 0.87994792140256, 0.889237849471334, 0.897425790062242, 0.904688304851229, 0.911166484840908, 0.916974461375408, 0.922205560262668, 0.926936833441981, 0.931232450014748, 0.935146270324233, 0.938723825147773, 0.942003855222286, 0.9450195214372, 0.947799365319983), "20" = c(0, 0.276598221109225, 0.480091816919932, 0.62207813892774, 0.720105357077801, 0.788404490421694, 0.83684648649206, 0.871903512170082, 0.897785391284217, 0.917254967437719, 0.932155415374907, 0.94373844195542, 0.952871658197302, 0.960166062946691, 0.96606101324546, 0.970874376612312, 0.974843755028167, 0.978145796062885, 0.98091616915103, 0.983256097985314, 0.985247325406535, 0.986952155066644, 0.988421752891467, 0.98969341361155, 0.990800873367999), "21" = c(-1.00148148148148, 0.347129116118547, 0.65564069685479, 0.780803624460825, 0.846443027861398, 0.885838814250034, 0.911560842980429, 0.929365274007805, 0.942234840854385, 0.951833301777067, 0.96008770231504, 0.965881283889428, 0.97252949040583, 0.97634531326702, 0.979070799707118, 0.99154650629721, 0.993599496406914, 1.00432643751157, 1.00555767252712, 1.03505473383290, 1.03618596470961, 1.05759086565101, 1.05873221403231, 1.11481166665537, 1.11507652990229), "22" = c(0, -0.0306367173028787, -0.0602746511903028, -0.0891338848924438, -0.117379804930934, -0.145140408516369, -0.172516725392443, -0.199589475575909, -0.226423523248459, -0.253070965533168, -0.279573384360126, -0.30596355638433, -0.332266726350362, -0.358501732266778, -0.384681876941774, -0.410815779550173, -0.436907762333632, -0.462959276965944, -0.488968041367581, -0.514929666432483, -0.540839175128809, -0.566687136331552, -0.592466001518449, -0.618164814543992, -0.643774208533738)), .Names = c("1", "2", "3", "4", "5", "6", "7", "8", "9", "10", "11", "12", "13", "14", "15", "16", "17", "18", "19", "20", "21", "22"), row.names = c("1", "2", "3", "4", "5", "6", "7", "8", "9", "10", "11", "12", "13", "14", "15", "16", "17", "18", "19", "20", "21", "22", "23", "24", "25"), class = "data.frame") ################################################################################ fCopulae/R/ExtremeValueCopulae.R0000644000176000001440000011274612406047540016320 0ustar ripleyusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA ################################################################################ # FUNCTION: EXTREME VALUE COPULAE RANDOM VARIATES: # revCopula Generates extreme value copula random variates # revSlider isplays interactively plots of random variates # FUNCTION: EXTREME VALUE COPULAE PROBABILIY: # pevCopula Computes extreme value copula probability # pevSlider Displays interactively plots of probability # .pev1Copula EV copula probability via dependence function # .pev2Copula EV copula probability direct computation # .pevContourSlider Interactive contour plots of EV probability # .pevPerspSlider Interactive perspective plots of EV probability # FUNCTION: EXTREME VALUE COPULAE DENSITY: # devCopula Computes extreme value copula density # devSlider Displays interactively plots of density # .dev1Copula EV copula density via dependence function # .dev2Copula EV copula density direct computation # .devContourSlider Interactive contour plots of EV density # .devPerspSlider Interactive perspective plots of EV density ################################################################################ ################################################################################ # FUNCTION: EXTREME VALUE COPULAE RANDOM VARIATES: # revCopula Generates extreme value copula random variates # revSlider Displays interactively plots of random variates revCopula <- function(n, param = NULL, type = evList()) { # Default Settings: subintervals = 100 u = runif(n) # Match Arguments: type = match.arg(type) # Check Parameters: if (is.null(param)) param = evParam(type)$param # Random Variates: q = runif(n) v = u Y = seq(0, 1, length = subintervals) for (i in 1:n) { U = rep(u[i], times = subintervals) C.uv = pevCopula(u = U, v = Y, param, type) / U x = log(U)/log(U*Y) A = Afunc(x, param, type) Aderiv = .AfuncFirstDer(x, param, type) X = C.uv * (A + Aderiv * log(Y)/log(U*Y)) v[i] = approx(X, Y, xout = q[i])$y } ans = cbind(u = u, v = v) # Add Control List: control = list(param = param, copula = "ev", type = type) attr(ans, "control")<-unlist(control) # Return Value: ans } # ------------------------------------------------------------------------------ revSlider <- function(B = 10) { # A function implemented by Diethelm Wuertz # Description: # Displays interactively perspective plots of random variates # FUNCTION: # Graphic Frame: par(mfrow = c(1, 1)) # Internal Function: refresh.code = function(...) { # Startup Counter: .counter <- getRmetricsOptions(".counter") + 1 setRmetricsOptions(.counter = .counter) if (.counter < 10) return () # Sliders: Type = evList() Copula = .sliderMenu(no = 1) N = .sliderMenu(no = 2) if (Copula <= 3) param = c(delta = .sliderMenu(no = Copula + 2)) if (Copula == 4) param = c(alpha = .sliderMenu(no = 6), beta = .sliderMenu(no = 7), r = .sliderMenu(no = 8)) if (Copula == 5) param = c(delta = .sliderMenu(no = 9), theta = .sliderMenu(no = 10)) # Title: type = Type[Copula] subTitle = paste(paste(names(param) , "="), param, collapse = " | " ) Title = paste(" ", type, "\n", subTitle) # Plot: R = revCopula(N, param = param, type = type) plot(R, pch = 19, col = "steelblue") grid() title(main = Title) # Reset Frame: par(mfrow = c(1, 1)) } # Open Slider Menu: setRmetricsOptions(.counter = 0) C = c("1 Gumbel: delta", "2 Galambos: delta", "3 Husler-Reis: delta", "4 Tawn: alpha", "... beta", "... r", "5 BB5: delta", "... theta") .sliderMenu(refresh.code, names = c("Copula", "N", C), # gumbel galamb h.r tawn-tawn-tawn bb5-bb5 minima = c(1, 100, 1, 0, 0, 0, 0, 1, 0, 1), maxima = c(5,5000, B, B, B, 1, 1, B, B, B), resolutions = c(1, 100, .05, .05, .05, .01, .01, .1, .1, .1), starts = c(1, 100, 2, 1, 1, .5, .5, 2, 1, 2)) } ################################################################################ # FUNCTION: EXTREME VALUE COPULAE PROBABILIY: # pevCopula Computes extreme value copula probability # pevSlider Displays interactively plots of probability # .pev1Copula EV copula probability via dependence function # .pev2Copula EV copula probability direct computation # .pevContourSlider Interactive contour plots of EV probability # .pevPerspSlider Interactive perspective plots of EV probability pevCopula <- function(u = 0.5, v = u, param = NULL, type = evList(), output = c("vector", "list"), alternative = FALSE ) { # A function implemented by Diethelm Wuertz # Description: # Computes extreme value copula probability # Arguments: # u, v - two numeric values or vectors of the same length at # which the copula will be computed. If 'u' is a list then the # the '$x' and '$y' elements will be used as 'u' and 'v'. # If 'u' is a two column matrix then the first column will # be used as 'u' and the the second as 'v'. # param - a numeric value or vector of named parameters as # required by the copula specified by the variable 'type'. # If set to NULL, then the parameters will be taken as # specified by the function 'evParam'. # type - the type of the maximum extreme value copula. A character # string selected from: "gumbel", "galambos", "husler.reiss", # "tawn", or "bb5". # output - a character string specifying how the output should # be formatted. By default a vector of the same length as # 'u' and 'v'. If specified as "list" then 'u' and 'v' are # expected to span a two-dimensional grid as outputted by the # function 'grid2d' and the function returns a list with # elements '$x', 'y', and 'z' which can be directly used # for example by 2D plotting functions. # alternative - Should the probability be computed alternatively # in a direct way from the probability formula or by default # via the dependency function? # Value: # returns a vector or list of probabilities depending on the # value of the "output" variable. # Example: # Diagonal Value: pevCopula((0:10)/10) # persp(pevCopula(u=grid2d(), output="list"), theta=-40, phi=30, xlab="x") # FUNCTION: # Select Type: type = match.arg(type) # Compute Copula: if (!alternative) { ans = .pev1Copula(u, v, param, type, output) } else { ans = .pev2Copula(u, v, param, type, output) } # Return Value: ans } # ------------------------------------------------------------------------------ pevSlider <- function(type = c("persp", "contour"), B = 10) { # A function implemented by Diethelm Wuertz # Description: # Displays interactively plots of probability # Arguments: # type - a character string specifying the plot type. # Either a perspective plot which is the default or # a contour plot with an underlying image plot will # be created. # B - the maximum slider menu value when the boundary # value is infinite. By default this is set to 10. # Match Arguments: type = match.arg(type) # Plot: if (type == "persp") .pevPerspSlider(B = B) if (type == "contour") .pevContourSlider(B = B) # Return Value: invisible() } # ------------------------------------------------------------------------------ .pev1Copula <- function(u = 0.5, v = u, param = NULL, type = evList(), output = c("vector", "list") ) { # A function implemented by Diethelm Wuertz # Description: # Computes extreme value copula probability via dependency function # FUNCTION: # Match Arguments: type = match.arg(type) output = match.arg(output) # Settings: if (is.null(param)) { param = evParam(type)$param } if (is.list(u)) { v = u$y u = u$x } if (is.matrix(u)) { v = u[, 2] u = u[, 1] } # Settings: log.u = log(u) log.v = log(v) x = log.u/(log.u+log.v) # Copula Probability: A = Afunc(x, param = param, type = type) C = exp((log.u+log.v) * A) names(C) = NULL # Simulates Max function: C = (C + abs(C))/2 # On Boundary: C[is.na(C)] = 0 C[which(u == 0)] = 0 C[which(u == 1)] = v[which(u == 1)] C[which(v == 0)] = 0 C[which(v == 1)] = u[which(v == 1)] C[which(u*v == 1)] = 1 C[which(u+v == 0)] = 0 # Result: attr(C, "control") <- unlist(list(param = param, type = type)) # As List ? if (output == "list") { N = sqrt(length(u)) x = u[1:N] y = matrix(v, ncol = N)[1, ] C = list(x = x, y = y, z = matrix(C, ncol = N)) } # Return Value: C } # ------------------------------------------------------------------------------ .pev2Copula <- function(u = 0.5, v = u, param = NULL, type = evList(), output = c("vector", "list") ) { # A function implemented by Diethelm Wuertz # Description: # Computes extreme value copula probability directly # FUNCTION: # Match Arguments: type = match.arg(type) output = match.arg(output) # Settings: if (is.null(param)) { param = evParam(type)$param } if (is.list(u)) { v = u$y u = u$x } if (is.matrix(u)) { v = u[, 2] u = u[, 1] } # Compute Probability: if (type == "gumbel") { alpha = param[1] C = exp(-((-log(u))^alpha + (-log(v))^alpha)^(1/alpha)) } if (type == "galambos") { alpha = param[1] u.tilde = -log(u) v.tilde = -log(v) C = u*v*exp(((u.tilde)^(-alpha) + (v.tilde)^(-alpha))^(-1/alpha)) } if (type == "husler.reiss") { alpha = param[1] u.tilde = -log(u) v.tilde = -log(v) C = exp(- u.tilde * pnorm(1/alpha + 0.5*alpha*log(u.tilde/v.tilde)) - v.tilde * pnorm(1/alpha + 0.5*alpha*log(v.tilde/u.tilde)) ) } if (type == "tawn") { b = param[1] a = param[2] r = param[3] log.uv = log(u*v) t = log(u)/log.uv A = 1-b+(b-a)*t+(a^r*t^r+b^r*(1-t)^r)^(1/r) C = exp(log.uv*A) } if (type == "bb5") { delta = param[1] theta = param[2] u.tilde = -log(u) v.tilde = -log(v) C = exp(-( u.tilde^theta + v.tilde^theta - ( u.tilde^(-theta*delta) + v.tilde^(-theta*delta) )^(-1/delta))^(1/theta)) } # Some more, yet untested and undocumented: if (type == "gumbelII") { alpha = param[1] C = u*v*exp(alpha*log(u)*log(v)/(log(u)+log(v))) } if (type == "marshall.olkin") { a = param[1] b = param[2] C = apply(cbind(v*u^(1-a), u*v^(1-b)), 1, min) } if (type == "pi" || type == "Cperp") { C = u*v } if (type == "m" || type == "Cplus") { C = apply(cbind(u, v), 1, min) } # Simulates Max function: C = (C + abs(C))/2 # On Boundary: C[is.na(C)] = 0 C[which(u == 0)] = 0 C[which(u == 1)] = v[which(u == 1)] C[which(v == 0)] = 0 C[which(v == 1)] = u[which(v == 1)] C[which(u*v == 1)] = 1 C[which(u+v == 0)] = 0 # Result: attr(C, "control") <- unlist(list(param = param, type = type)) # As List ? if (output == "list") { N = sqrt(length(u)) x = u[1:N] y = matrix(v, ncol = N)[1, ] C = list(x = x, y = y, z = matrix(C, ncol = N)) } # Return Value: C } # ------------------------------------------------------------------------------ .pevContourSlider <- function(B = 10) { # A function implemented by Diethelm Wuertz # Description: # Displays interactively contour plots of probability #FUNCTION: # Graphic Frame: par(mfrow = c(1, 1)) # Internal Function: refresh.code = function(...) { # Startup Counter: .counter <- getRmetricsOptions(".counter") + 1 setRmetricsOptions(.counter = .counter) if (.counter < 10) return () # Sliders: Type = evList() Copula = .sliderMenu(no = 1) N = .sliderMenu(no = 2) if (Copula <= 3) param = c(delta = .sliderMenu(no = Copula + 2)) if (Copula == 4) param = c(alpha = .sliderMenu(no = 6), beta = .sliderMenu(no = 7), r = .sliderMenu(no = 8)) if (Copula == 5) param = c(delta = .sliderMenu(no = 9), theta = .sliderMenu(no = 10)) nlev = .sliderMenu(no = 11) ncol = .sliderMenu(no = 12) # Title: type = Type[Copula] subTitle = paste(paste(names(param) , "="), param, collapse = " | " ) Title = paste(" ", type, "\n", subTitle) # Plot: uv = grid2d(x = (0:N)/N) D = .pev1Copula(u = uv, type = type, param = param, output = "list") image(D, col = heat.colors(ncol) ) contour(D, nlevels = nlev, add = TRUE) title(main = Title) # Reset Frame: par(mfrow = c(1, 1)) } # Open Slider Menu: setRmetricsOptions(.counter = 0) C = c("1 Gumbel: delta", "2 Galambos: delta", "3 Husler-Reis: delta", "4 Tawn: alpha", "... beta", "... r", "5 BB5: delta", "... theta", "Plot - levels", "... colors") .sliderMenu(refresh.code, names = c("Copula","N", C), #gal hr tawn bb5 nlev ncol minima = c(1, 10, 1, 0, 0, 0, 0, 1, 0, 1, 5, 12), maxima = c(5, 100, B, B, B, 1, 1, B, B, B, 100, 256), resolutions = c(1, 1, .05, .05, .05, .01, .01, .1, .1, .1, 5, 1), starts = c(1, 25, 2, 1, 1, .5, .5, 2, 1, 2, 10, 12)) } # ------------------------------------------------------------------------------ .pevPerspSlider <- function(B = 10) { # A function implemented by Diethelm Wuertz # Description: # Displays interactively perspective plots of probability #FUNCTION: # Graphic Frame: par(mfrow = c(1, 1)) # Internal Function: refresh.code = function(...) { # Startup Counter: .counter <- getRmetricsOptions(".counter") + 1 setRmetricsOptions(.counter = .counter) if (.counter < 12) return () # Sliders: Type = evList() Copula = .sliderMenu(no = 1) N = .sliderMenu(no = 2) if (Copula <= 3) param = c(delta = .sliderMenu(no = Copula + 2)) if (Copula == 4) param = c(alpha = .sliderMenu(no = 6), beta = .sliderMenu(no = 7), r = .sliderMenu(no = 8)) if (Copula == 5) param = c(delta = .sliderMenu(no = 9), theta = .sliderMenu(no = 10)) theta = .sliderMenu(no = 11) phi = .sliderMenu(no = 12) # Title: type = Type[Copula] subTitle = paste(paste(names(param) , "="), param, collapse = " | " ) Title = paste(" ", type, "\n", subTitle) # Plot: uv = grid2d(x = (0:N)/N) D = .pev1Copula(u = uv, type = type, param = param, output = "list") #D2 = .pev2Copula(u = uv, type = type, param = param, output = "list") persp(D, theta = theta, phi = phi, col = "steelblue", shade = 0.5, ticktype = "detailed", cex = 0.5) title(main = Title) # Reset Frame: par(mfrow = c(1, 1)) } # Open Slider Menu: setRmetricsOptions(.counter = 0) C = c("1 Gumbel: delta", "2 Galambos: delta", "3 Husler-Reis: delta", "4 Tawn: alpha", "... beta", "... r", "5 BB5: delta", "... theta", "Plot - theta", "... phi") .sliderMenu(refresh.code, names = c("Copula", "N", C), #gal hr tawn bb5 theta phi minima = c(1, 10, 1, 0, 0, 0, 0, 1, 0, 1, -180, 0), maxima = c(5, 100, B, B, B, 1, 1, B, B, B, 180, 360), resolutions = c(1, 1, .05, .05, .05, .01, .01, .1, .1, .1, 1, 1), starts = c(1, 25, 2, 1, 1, .5, .5, 2, 1, 2, -40, 30)) } ################################################################################ # FUNCTION: EXTREME VALUE COPULAE DENSITY: # devCopula Computes extreme value copula density # devSlider Displays interactively plots of density # .dev1Copula EV copula density via dependence function # .dev2Copula EV copula density direct computation # .devContourSlider Interactive contour plots of EV density # .devPerspSlider Interactive perspective plots of EV density devCopula <- function(u = 0.5, v = u, param = NULL, type = evList(), output = c("vector", "list"), alternative = FALSE ) { # A function implemented by Diethelm Wuertz # Description: # Computes extreme value copula density from dependence function # Arguments: # u, v - two numeric values or vectors of the same length at # which the copula will be computed. If 'u' is a list then the # the '$x' and '$y' elements will be used as 'u' and 'v'. # If 'u' is a two column matrix then the first column will # be used as 'u' and the the second as 'v'. # param - a numeric value or vector of named parameters as # required by the copula specified by the variable 'type'. # If set to NULL, then the parameters will be taken as # specified by the function 'evParam'. # type - the type of the maximum extreme value copula. A character # string selected from: "gumbel", "galambos", "husler.reiss", # "tawn", or "bb5". # output - a character string specifying how the output should # be formatted. By default a vector of the same length as # 'u' and 'v'. If specified as "list" then 'u' and 'v' are # expected to span a two-dimensional grid as outputted by the # function 'grid2d' and the function returns a list with # elements '$x', 'y', and 'z' which can be directly used # for example by 2D plotting functions. # alternative - Should the density be computed alternatively # in a direct way from the probability formula or by default # via the dependency function? # Value: # returns a vector or list of density values depending on the # value of the "output" variable. # Example: # Diagonal Value: devCopula((0:10)/10) # persp(devCopula(u=grid2d(), output="list"), theta=-40, phi=30, xlab="x") # FUNCTION: # Match Arguments: type = match.arg(type) output = match.arg(output) # Copula Density: if (alternative) { ans = .dev2Copula(u, v, param, type, output) } else { ans = .dev1Copula(u, v, param, type, output) } # Return Value: ans } # ------------------------------------------------------------------------------ devSlider = function(type = c("persp", "contour"), B = 10) { # A function implemented by Diethelm Wuertz # Description: # Displays interactively plots of probability # Arguments: # type - a character string specifying the plot type. # Either a perspective plot which is the default or # a contour plot with an underlying image plot will # be created. # B - the maximum slider menu value when the boundary # value is infinite. By default this is set to 10. # Match Arguments: type = match.arg(type) # Plot: if (type == "persp") .devPerspSlider(B = B) if (type == "contour") .devContourSlider(B = B) # Return Value: invisible() } # ------------------------------------------------------------------------------ .dev1Copula <- function(u = 0.5, v = u, param = NULL, type = evList(), output = c("vector", "list") ) { # A function implemented by Diethelm Wuertz # Description: # Computes extreme value copula density from dependence function # Example: # Diagonal Value: devCopula((0:10)/10) # persp(devCopula(u=grid2d(), output="list"), theta=-40, phi=30, xlab="x") # FUNCTION: # Match Arguments: type = match.arg(type) output = match.arg(output) # Settings: if (is.null(param)) { param = evParam(type)$param } if (is.list(u)) { v = u$y u = u$x } if (is.matrix(u)) { v = u[, 2] u = u[, 1] } # Settings for Maple Output: Pi = pi ln = function(x) { log(x) } erf = function (x) { 2*pnorm(sqrt(2)*x)-1 } # Further Settings: log.u = log(u) log.v = log(v) x = log.u/(log.u+log.v) y = log.v/(log.u+log.v) # Copula Probability: A = Afunc(x, param = param, type = type) A1 = .AfuncFirstDer(x, param = param, type = type) A2 = .AfuncSecondDer(x, param = param, type = type) # Prefactor: P = pevCopula(u, v, param = param, type = type) / (u*v) c.uv = P * (( -x*y/(log.u+log.v))*A2 + (A+y*A1)*(A-x*A1) ) c.uv[which(u*v == 0 | u*v == 1)] = 0 # Result: attr(c.uv, "control") <- unlist(list(param = param, type = type)) # As List ? if (output == "list") { N = sqrt(length(u)) x = u[1:N] y = matrix(v, ncol = N)[1, ] c.uv = list(x = x, y = y, z = matrix(c.uv, ncol = N)) } # Return Value: c.uv } # ------------------------------------------------------------------------------ .dev2Copula <- function(u = 0.5, v = u, param = NULL, type = evList(), output = c("vector", "list") ) { # A function implemented by Diethelm Wuertz # Description: # Computes extreme value copula density directly # Details: # List - 9 Types: # pi[Cperp], gumbel, gumbelII, galambos, husler.reiss, # tawn, bb5, marshall.olkin, m[Cplus] # References: # Carmona, Evanesce # FUNCTION: # Match Arguments: type = match.arg(type) output = match.arg(output) # Settings: if (is.null(param)) { param = evParam(type)$param } if (is.list(u)) { v = u$y u = u$x } if (is.matrix(u)) { v = u[, 2] u = u[, 1] } # Settings: if (is.null(param)) param = evParam[[type]] Pi = pi ln = function(x) { log(x) } erf = function (x) { 2*pnorm(sqrt(2)*x)-1 } # Compute Probability: if (type == "gumbel") { alpha = param[1] # Maple Generated Output: c.uv = -((-ln(u))^alpha+(-ln(v))^alpha)^(1/alpha)*(-ln(v))^alpha/v/ln(v)/( (-ln(u))^alpha+(-ln(v))^alpha)^2*(-ln(u))^alpha/u/ln(u)*exp(-((-ln( u))^alpha+(-ln(v))^alpha)^(1/alpha))+((-ln(u))^alpha+(-ln(v))^alpha )^(1/alpha)*(-ln(u))^alpha/u/ln(u)/((-ln(u))^alpha+(-ln(v))^alpha)^ 2*exp(-((-ln(u))^alpha+(-ln(v))^alpha)^(1/alpha))*(-ln(v))^alpha* alpha/v/ln(v)+(((-ln(u))^alpha+(-ln(v))^alpha)^(1/alpha))^2*(-ln(u) )^alpha/u/ln(u)/((-ln(u))^alpha+(-ln(v))^alpha)^2*(-ln(v))^alpha/v/ ln(v)*exp(-((-ln(u))^alpha+(-ln(v))^alpha)^(1/alpha)) } if (type == "galambos") { alpha = param[1] # Maple Generated Output: c.uv = exp(((-ln(u))^(-alpha)+(-ln(v))^(-alpha))^(-1/alpha))+((-ln(u))^(- alpha)+(-ln(v))^(-alpha))^(-1/alpha)*(-ln(v))^(-alpha)/ln(v)/((-ln( u))^(-alpha)+(-ln(v))^(-alpha))*exp(((-ln(u))^(-alpha)+(-ln(v))^(- alpha))^(-1/alpha))+((-ln(u))^(-alpha)+(-ln(v))^(-alpha))^(-1/alpha )*(-ln(u))^(-alpha)/ln(u)/((-ln(u))^(-alpha)+(-ln(v))^(-alpha))*exp( ((-ln(u))^(-alpha)+(-ln(v))^(-alpha))^(-1/alpha))+((-ln(u))^(- alpha)+(-ln(v))^(-alpha))^(-1/alpha)*(-ln(v))^(-alpha)/ln(v)/((-ln( u))^(-alpha)+(-ln(v))^(-alpha))^2*(-ln(u))^(-alpha)/ln(u)*exp(((-ln (u))^(-alpha)+(-ln(v))^(-alpha))^(-1/alpha))+((-ln(u))^(-alpha)+(- ln(v))^(-alpha))^(-1/alpha)*(-ln(u))^(-alpha)/ln(u)/((-ln(u))^(- alpha)+(-ln(v))^(-alpha))^2*exp(((-ln(u))^(-alpha)+(-ln(v))^(-alpha ))^(-1/alpha))*(-ln(v))^(-alpha)*alpha/ln(v)+(((-ln(u))^(-alpha)+(- ln(v))^(-alpha))^(-1/alpha))^2*(-ln(u))^(-alpha)/ln(u)/((-ln(u))^(- alpha)+(-ln(v))^(-alpha))^2*(-ln(v))^(-alpha)/ln(v)*exp(((-ln(u))^( -alpha)+(-ln(v))^(-alpha))^(-1/alpha)) } if (type == "husler.reiss") { # Maple Generated Output: c.uv = (-.2500000000/u/Pi^(1/2)*exp(-1/2*(1/alpha+.5*alpha*ln(ln(u)/ln(v)) )^2)*alpha/v/ln(v)*2^(1/2)+.1250000000/Pi^(1/2)*(1/alpha+.5*alpha* ln(ln(u)/ln(v)))*alpha^2/v/ln(v)*exp(-1/2*(1/alpha+.5*alpha*ln(ln(u )/ln(v)))^2)/u*2^(1/2)-.2500000000/v/Pi^(1/2)*exp(-1/2*(1/alpha+.5* alpha*ln(ln(v)/ln(u)))^2)*alpha/u/ln(u)*2^(1/2)+.1250000000/Pi^(1/2 )*(1/alpha+.5*alpha*ln(ln(v)/ln(u)))*alpha^2/v*exp(-1/2*(1/alpha+.5 *alpha*ln(ln(v)/ln(u)))^2)/u/ln(u)*2^(1/2))*exp(.5*ln(u)*(erf(1/2*( 1/alpha+.5*alpha*ln(ln(u)/ln(v)))*2^(1/2))+1)+.5*ln(v)*(erf(1/2*(1/ alpha+.5*alpha*ln(ln(v)/ln(u)))*2^(1/2))+1))+(.5/u*(erf(1/2*(1/ alpha+.5*alpha*ln(ln(u)/ln(v)))*2^(1/2))+1)+.2500000000/Pi^(1/2)* exp(-1/2*(1/alpha+.5*alpha*ln(ln(u)/ln(v)))^2)*alpha/u*2^(1/2)-.25* ln(v)/Pi^(1/2)*exp(-1/2*(1/alpha+.5*alpha*ln(ln(v)/ln(u)))^2)* alpha/u/ln(u)*2^(1/2))*(-.2500000000*ln(u)/Pi^(1/2)*exp(-1/2*(1/ alpha+.5*alpha*ln(ln(u)/ln(v)))^2)*alpha/v/ln(v)*2^(1/2)+.5/v*(erf( 1/2*(1/alpha+.5*alpha*ln(ln(v)/ln(u)))*2^(1/2))+1)+.2500000000/Pi^( 1/2)*exp(-1/2*(1/alpha+.5*alpha*ln(ln(v)/ln(u)))^2)*alpha/v*2^(1/2) )*exp(.5*ln(u)*(erf(1/2*(1/alpha+.5*alpha*ln(ln(u)/ln(v)))*2^(1/2)) +1)+.5*ln(v)*(erf(1/2*(1/alpha+.5*alpha*ln(ln(v)/ln(u)))*2^(1/2))+1 )) } if (type == "tawn") { # 0 <= alpha, beta <= 1, 1 <= r < Inf b = param[1] a = param[2] r = param[3] # Maple Generated Output: c.uv = (-(b-a)/u/ln(u*v)^2/v+2*(b-a)*ln(u)/ln(u*v)^3/u/v+(a^r*(ln(u)/ln(u* v))^r+b^r*(1-ln(u)/ln(u*v))^r)^(1/r)/r^2*(-a^r*(ln(u)/ln(u*v))^r*r/ ln(u*v)/v+b^r*(1-ln(u)/ln(u*v))^r*r*ln(u)/ln(u*v)^2/v/(1-ln(u)/ln(u *v)))/(a^r*(ln(u)/ln(u*v))^r+b^r*(1-ln(u)/ln(u*v))^r)^2*(a^r*(ln(u) /ln(u*v))^r*r*(1/u/ln(u*v)-ln(u)/ln(u*v)^2/u)/ln(u)*ln(u*v)+b^r*(1- ln(u)/ln(u*v))^r*r*(-1/u/ln(u*v)+ln(u)/ln(u*v)^2/u)/(1-ln(u)/ln(u*v )))+(a^r*(ln(u)/ln(u*v))^r+b^r*(1-ln(u)/ln(u*v))^r)^(1/r)/r*(-a^r*( ln(u)/ln(u*v))^r*r^2/v*(1/u/ln(u*v)-ln(u)/ln(u*v)^2/u)/ln(u)+a^r*( ln(u)/ln(u*v))^r*r*(-1/u/ln(u*v)^2/v+2*ln(u)/ln(u*v)^3/u/v)/ln(u)* ln(u*v)+a^r*(ln(u)/ln(u*v))^r*r*(1/u/ln(u*v)-ln(u)/ln(u*v)^2/u)/ln( u)/v+b^r*(1-ln(u)/ln(u*v))^r*r^2*ln(u)/ln(u*v)^2/v/(1-ln(u)/ln(u*v) )^2*(-1/u/ln(u*v)+ln(u)/ln(u*v)^2/u)+b^r*(1-ln(u)/ln(u*v))^r*r*(1/u /ln(u*v)^2/v-2*ln(u)/ln(u*v)^3/u/v)/(1-ln(u)/ln(u*v))-b^r*(1-ln(u)/ ln(u*v))^r*r*(-1/u/ln(u*v)+ln(u)/ln(u*v)^2/u)/(1-ln(u)/ln(u*v))^2* ln(u)/ln(u*v)^2/v)/(a^r*(ln(u)/ln(u*v))^r+b^r*(1-ln(u)/ln(u*v))^r)- (a^r*(ln(u)/ln(u*v))^r+b^r*(1-ln(u)/ln(u*v))^r)^(1/r)/r*(a^r*(ln(u) /ln(u*v))^r*r*(1/u/ln(u*v)-ln(u)/ln(u*v)^2/u)/ln(u)*ln(u*v)+b^r*(1- ln(u)/ln(u*v))^r*r*(-1/u/ln(u*v)+ln(u)/ln(u*v)^2/u)/(1-ln(u)/ln(u*v )))/(a^r*(ln(u)/ln(u*v))^r+b^r*(1-ln(u)/ln(u*v))^r)^2*(-a^r*(ln(u)/ ln(u*v))^r*r/ln(u*v)/v+b^r*(1-ln(u)/ln(u*v))^r*r*ln(u)/ln(u*v)^2/v/ (1-ln(u)/ln(u*v))))*exp(ln(u*v)-b+(b-a)*ln(u)/ln(u*v)+(a^r*(ln(u)/ ln(u*v))^r+b^r*(1-ln(u)/ln(u*v))^r)^(1/r))+(1/u+(b-a)/u/ln(u*v)-(b- a)*ln(u)/ln(u*v)^2/u+(a^r*(ln(u)/ln(u*v))^r+b^r*(1-ln(u)/ln(u*v))^r )^(1/r)/r*(a^r*(ln(u)/ln(u*v))^r*r*(1/u/ln(u*v)-ln(u)/ln(u*v)^2/u)/ ln(u)*ln(u*v)+b^r*(1-ln(u)/ln(u*v))^r*r*(-1/u/ln(u*v)+ln(u)/ln(u*v) ^2/u)/(1-ln(u)/ln(u*v)))/(a^r*(ln(u)/ln(u*v))^r+b^r*(1-ln(u)/ln(u*v ))^r))*(1/v-(b-a)*ln(u)/ln(u*v)^2/v+(a^r*(ln(u)/ln(u*v))^r+b^r*(1- ln(u)/ln(u*v))^r)^(1/r)/r*(-a^r*(ln(u)/ln(u*v))^r*r/ln(u*v)/v+b^r*( 1-ln(u)/ln(u*v))^r*r*ln(u)/ln(u*v)^2/v/(1-ln(u)/ln(u*v)))/(a^r*(ln( u)/ln(u*v))^r+b^r*(1-ln(u)/ln(u*v))^r))*exp(ln(u*v)-b+(b-a)*ln(u)/ ln(u*v)+(a^r*(ln(u)/ln(u*v))^r+b^r*(1-ln(u)/ln(u*v))^r)^(1/r)) } if (type == "bb5") { # delta > 0, theta >= 1 delta = param[1] theta = param[2] # Maple Generated Output: c.uv = -((-ln(u))^theta+(-ln(v))^theta-((-ln(u))^(-theta*delta)+(-ln(v))^( -theta*delta))^(-1/delta))^(1/theta)/theta^2*((-ln(v))^theta*theta/ v/ln(v)-((-ln(u))^(-theta*delta)+(-ln(v))^(-theta*delta))^(-1/delta )*(-ln(v))^(-theta*delta)*theta/v/ln(v)/((-ln(u))^(-theta*delta)+(- ln(v))^(-theta*delta)))/((-ln(u))^theta+(-ln(v))^theta-((-ln(u))^(- theta*delta)+(-ln(v))^(-theta*delta))^(-1/delta))^2*((-ln(u))^theta *theta/u/ln(u)-((-ln(u))^(-theta*delta)+(-ln(v))^(-theta*delta))^(- 1/delta)*(-ln(u))^(-theta*delta)*theta/u/ln(u)/((-ln(u))^(-theta* delta)+(-ln(v))^(-theta*delta)))*exp(-((-ln(u))^theta+(-ln(v))^ theta-((-ln(u))^(-theta*delta)+(-ln(v))^(-theta*delta))^(-1/delta)) ^(1/theta))-((-ln(u))^theta+(-ln(v))^theta-((-ln(u))^(-theta*delta) +(-ln(v))^(-theta*delta))^(-1/delta))^(1/theta)/theta*(-((-ln(u))^( -theta*delta)+(-ln(v))^(-theta*delta))^(-1/delta)*(-ln(v))^(-theta* delta)*theta^2/v/ln(v)/((-ln(u))^(-theta*delta)+(-ln(v))^(-theta* delta))^2*(-ln(u))^(-theta*delta)/u/ln(u)-((-ln(u))^(-theta*delta)+ (-ln(v))^(-theta*delta))^(-1/delta)*(-ln(u))^(-theta*delta)*theta^2 /u/ln(u)/((-ln(u))^(-theta*delta)+(-ln(v))^(-theta*delta))^2*(-ln(v ))^(-theta*delta)*delta/v/ln(v))/((-ln(u))^theta+(-ln(v))^theta-((- ln(u))^(-theta*delta)+(-ln(v))^(-theta*delta))^(-1/delta))*exp(-((- ln(u))^theta+(-ln(v))^theta-((-ln(u))^(-theta*delta)+(-ln(v))^(- theta*delta))^(-1/delta))^(1/theta))+((-ln(u))^theta+(-ln(v))^theta -((-ln(u))^(-theta*delta)+(-ln(v))^(-theta*delta))^(-1/delta))^(1/ theta)/theta*((-ln(u))^theta*theta/u/ln(u)-((-ln(u))^(-theta*delta) +(-ln(v))^(-theta*delta))^(-1/delta)*(-ln(u))^(-theta*delta)*theta/ u/ln(u)/((-ln(u))^(-theta*delta)+(-ln(v))^(-theta*delta)))/((-ln(u) )^theta+(-ln(v))^theta-((-ln(u))^(-theta*delta)+(-ln(v))^(-theta* delta))^(-1/delta))^2*exp(-((-ln(u))^theta+(-ln(v))^theta-((-ln(u)) ^(-theta*delta)+(-ln(v))^(-theta*delta))^(-1/delta))^(1/theta))*((- ln(v))^theta*theta/v/ln(v)-((-ln(u))^(-theta*delta)+(-ln(v))^(- theta*delta))^(-1/delta)*(-ln(v))^(-theta*delta)*theta/v/ln(v)/((- ln(u))^(-theta*delta)+(-ln(v))^(-theta*delta)))+(((-ln(u))^theta+(- ln(v))^theta-((-ln(u))^(-theta*delta)+(-ln(v))^(-theta*delta))^(-1/ delta))^(1/theta))^2/theta^2*((-ln(u))^theta*theta/u/ln(u)-((-ln(u) )^(-theta*delta)+(-ln(v))^(-theta*delta))^(-1/delta)*(-ln(u))^(- theta*delta)*theta/u/ln(u)/((-ln(u))^(-theta*delta)+(-ln(v))^(- theta*delta)))/((-ln(u))^theta+(-ln(v))^theta-((-ln(u))^(-theta* delta)+(-ln(v))^(-theta*delta))^(-1/delta))^2*((-ln(v))^theta*theta /v/ln(v)-((-ln(u))^(-theta*delta)+(-ln(v))^(-theta*delta))^(-1/ delta)*(-ln(v))^(-theta*delta)*theta/v/ln(v)/((-ln(u))^(-theta* delta)+(-ln(v))^(-theta*delta)))*exp(-((-ln(u))^theta+(-ln(v))^ theta-((-ln(u))^(-theta*delta)+(-ln(v))^(-theta*delta))^(-1/delta)) ^(1/theta)) } # Result: attr(c.uv, "control") <- unlist(list(param = param, type = type)) # As List ? if (output[1] == "list") { N = sqrt(length(u)) x = u[1:N] y = matrix(v, ncol = N)[1, ] c.uv = list(x = x, y = y, z = matrix(c.uv, ncol = N)) } # Return Value: c.uv } # ------------------------------------------------------------------------------ .devContourSlider <- function(B = 10) { # A function implemented by Diethelm Wuertz # Description: # Displays interactively contour plots of density # FUNCTION: # Internal Function: refresh.code = function(...) { # Startup Counter: .counter <- getRmetricsOptions(".counter") + 1 setRmetricsOptions(.counter = .counter) if (.counter < 12) return () # Sliders: Type = evList() Copula = .sliderMenu(no = 1) N = .sliderMenu(no = 2) if (Copula <= 3) param = c(delta = .sliderMenu(no = Copula + 2)) if (Copula == 4) param = c(alpha = .sliderMenu(no = 6), beta = .sliderMenu(no = 7), r = .sliderMenu(no = 8)) if (Copula == 5) param = c(delta = .sliderMenu(no = 9), theta = .sliderMenu(no = 10)) nlev = .sliderMenu(no = 11) ncol = .sliderMenu(no = 12) # Title: type = Type[Copula] subTitle = paste(paste(names(param) , "="), param, collapse = " | " ) Title = paste(" ", type, "\n", subTitle) # Plot: n = N/2 F = (2*1.0e-2)^(1/n) x = 0.5*F^(1:n) x = c(rev(x), 0.5, 1-x) uv = grid2d(x = (1:(N-1))/N) D = .dev1Copula(u = uv, type = type, param = param, output = "list") image(D, col = heat.colors(ncol) ) contour(D, nlevels = nlev, add = TRUE) title(main = Title) # Reset Frame: par(mfrow = c(1, 1)) } # Open Slider Menu: setRmetricsOptions(.counter = 0) C = c("1 Gumbel: delta", "2 Galambos: delta", "3 Husler-Reis: delta", "4 Tawn: alpha", "... beta", "... r", "5 BB5: delta", "... theta", "Plot - levels", "... colors") .sliderMenu(refresh.code, names = c("Copula","N", C), #gal hr tawn bb5 nlev ncol minima = c(1, 10, 1, 0, 0, 0, 0, 1, 0, 1, 5, 12), maxima = c(5, 100, B, B, B, 1, 1, B, B, B, 100, 256), resolutions = c(1, 5, .05, .05, .05, .01, .01, .1, .1, .1, 5, 1), starts = c(1, 25, 2, 1, 1, .5, .5, 2, 1, 2, 10, 12)) } # ------------------------------------------------------------------------------ .devPerspSlider <- function(B = 10) { # A function implemented by Diethelm Wuertz # Description: # Displays interactively contour plots of density #FUNCTION: # Internal Function: refresh.code = function(...) { # Startup Counter: .counter <- getRmetricsOptions(".counter") + 1 setRmetricsOptions(.counter = .counter) if (.counter < 12) return () # Sliders: Type = evList() Copula = .sliderMenu(no = 1) N = .sliderMenu(no = 2) if (Copula <= 3) param = c(delta = .sliderMenu(no = Copula + 2)) if (Copula == 4) param = c(alpha = .sliderMenu(no = 6), beta = .sliderMenu(no = 7), r = .sliderMenu(no = 8)) if (Copula == 5) param = c(delta = .sliderMenu(no = 9), theta = .sliderMenu(no = 10)) theta = .sliderMenu(no = 11) phi = .sliderMenu(no = 12) # Title: type = Type[Copula] subTitle = paste(paste(names(param) , "="), param, collapse = " | " ) Title = paste(" ", type, "\n", subTitle) # Plot: n = N/2 F = (2*1.0e-2)^(1/n) x = 0.5*F^(1:n) x = c(rev(x), 0.5, 1-x) uv = grid2d(x = x) D = .dev1Copula(u = uv, type = type, param = param, output = "list") persp(D, theta = theta, phi = phi, col = "steelblue", shade = 0.5, ticktype = "detailed", cex = 0.5) title(main = Title) # Reset Frame: par(mfrow = c(1, 1)) } # Open Slider Menu: setRmetricsOptions(.counter = 12) C = c("1 Gumbel: delta", "2 Galambos: delta", "3 Husler-Reis: delta", "4 Tawn: alpha", "... beta", "... r", "5 BB5: delta", "... theta", "Plot - theta", "... phi") .sliderMenu(refresh.code, names = c("Copula", "N", C), #gal hr tawn bb5 theta phi minima = c(1, 10, 1, 0, 0, 0, 0, 1, 0, 1, -180, 0), maxima = c(5, 100, B, B, B, 1, 1, B, B, B, 180, 360), resolutions = c(1, 5, .05, .05, .05, .01, .01, .1, .1, .1, 1, 1), starts = c(1, 25, 2, 1, 1, .5, .5, 2, 1, 2, -40, 30)) } ################################################################################ fCopulae/R/aaaCopulaeClass.R0000644000176000001440000001657212406047540015422 0ustar ripleyusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA ############################################################################### # FUNCTION: COPULA SPECIFICATION: # fCOPULA S4 class representation # show S4 print method for copula specification # FUNCTION: FRECHET COPULA: # pfrechetCopula Computes Frechet copula probability # FUNCTION: SPEARMAN'S RHO: # .copulaRho Spearman's rho by integration for "ANY" copula ################################################################################ ################################################################################ setClass("fCOPULA", # Description: # Specifying and creating copula objects # Copula Representation: representation( call = "call", copula = "character", param = "list", title = "character", description = "character") ) # ------------------------------------------------------------------------------ setMethod("show", "fCOPULA", function(object) { # A function implemented by Diethelm Wuertz # Description: # Print and Summary method for fCOPULA # Source: # This function copies code from base:print.htest # FUNCTION: # Unlike print the argument for show is 'object'. x = object # Title: cat("\nTitle:\n ", x@title, "\n", sep = "") # Call: cat("\nCall:\n ") cat(paste(deparse(x@call), sep = "\n", collapse = "\n"), "\n", sep = "") # Copula Type: cat("\nCopula:\n ", x@copula, "\n", sep = "") # Model Parameter: if (length(x@param) != 0) { cat("\nModel Parameter(s):\n ") print(unlist(x@param), quote = FALSE) } # Description: cat("\nDescription:\n ", x@description, sep = "") cat("\n\n") # Return Value: invisible(object) }) ################################################################################ # Frechet Copulae: pfrechetCopula <- function(u = 0.5, v = u, type = c("m", "pi", "w"), output = c("vector", "list")) { # A function implemented by Diethelm Wuertz # Description: # Computes Frechet copula probability # Arguments: # u, v - two numeric values or vectors of the same length at # which the copula will be computed. If 'u' is a list then the # the '$x' and '$y' elements will be used as 'u' and 'v'. # If 'u' is a two column matrix then the first column will # be used as 'u' and the the second as 'v'. # type - the type of the Frechet copula. A character # string selected from: "m", "pi", or "w". # output - a character string specifying how the output should # be formatted. By default a vector of the same length as # 'u' and 'v'. If specified as "list" then 'u' and 'v' are # expected to span a two-dimensional grid as outputted by the # function 'grid2d' and the function returns a list with # elements '$x', 'y', and 'z' which can be directly used # for example by 2D plotting functions. # Examples: # persp(pfrechetCopula(u=grid2d(), output="list", type = "m")) # persp(pfrechetCopula(u=grid2d(), output="list", type = "pi")) # persp(pfrechetCopula(u=grid2d(), output="list", type = "w")) # FUNCTION: # Match Arguments: type = type[1] # Allow for "psp" ... # type = match.arg(type) output = match.arg(output) # Settings: if (is.list(u)) { v = u[[2]] u = u[[1]] } if (is.matrix(u)) { v = u[, 1] u = u[, 2] } # Compute Copula Probability: if (type == "m") { # C(u,v) = min(u,v) C.uv = apply(cbind(u, v), 1, min) } if (type == "pi") { # C(u, v) = u * v C.uv = u * v } if (type == "w") { # C(u,v) = max(u+v-1, 0) C.uv = apply(cbind(X = u+v-1, Y = rep(0, length = length(u))), 1, max) } if (type == "psp") { # C(u,v) = u*v/(u+v-u*v) C.uv = u*v/(u+v-u*v) } # Add Control: attr(C.uv, "control") <- unlist(list(type = type)) # As List ? if (output == "list") { N = sqrt(length(u)) x = u[1:N] y = matrix(v, ncol = N)[1, ] C.uv = list(x = x, y = y, z = matrix(C.uv, ncol = N)) } # Return Value: C.uv } ################################################################################ .copulaRho = function(rho = NULL, alpha = NULL, param = NULL, family = c("elliptical", "archm", "ev", "archmax"), type = NULL, error = 1e-3, ...) { # A function implemented by Diethelm Wuertz # Description: # Spearman's rho by integration for "ANY" copula # Notes: # pellipticalCopula(u, v, rho, param, type, output, border) # parchmCopula (u, v, alpha, type, output, alternative) # pevCopula (u, v, param, type, output, alternative) # parchmaxCopula (u, v, param, type, output ) # Examples: # .copulaRho(rho = 0.5, family = "elliptical", type = "norm") # .copulaRho(alpha = 1, family = "archm", type = "1") # .copulaRho(param = 2, family = "ev", type = "galambos") # FUNCTION: # Match Arguments: family = match.arg(family) # Type: if (is.null(type)) { family = "elliptical" type = "norm" } else { type = as.character(type) } # 2D Function to be integrated: rho <<- rho alpha <<- alpha param <<- param type <<- type if (family == "elliptical") { dCopulaRho <- function(x, y) { C = pellipticalCopula(x, y, rho = rho, param = param, type = type) 12 * (C - x*y ) } } else if (family == "archm") { if (is.null(alpha)) alpha <<- archmParam(type)$param check = archmCheck(alpha, type) dCopulaRho <- function(x, y) { C = parchmCopula(x, y, alpha = alpha, type = type) 12 * (C - x*y ) } } else if (family == "ev") { dCopulaRho <- function(x, y) { C = pevCopula(x, y, param = param, type = type) 12 * (C - x*y ) } } # else if (family == "archmax") { # dCopulaRho <- function(x, y) { # C = parchmaxCopula(x, y, param = param, type = type) # 12 * (C - x*y ) # } # } # Integrate: ans = integrate2d(dCopulaRho, error = error) Rho = ans$value error = ans$error # Result: control = list(rho = rho, alpha = alpha, param = param, family = family, type = type, error = signif(error, 3)) attr(Rho, "control") <- unlist(control) # Return Value: Rho } ################################################################################ fCopulae/R/EllipticalModelling.R0000644000176000001440000001363612406047540016314 0ustar ripleyusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA ################################################################################ # FUNCTION: ELLIPTICAL COPULAE PARAMETER FITTING: # ellipticalCopulaSim Simulates bivariate elliptical copula # ellipticalCopulaFit Fits the paramter of an elliptical copula ################################################################################ ################################################################################ # FUNCTION: ELLIPTICAL COPULAE PARAMETER FITTING: # ellipticalCopulaSim Simulates bivariate elliptical copula # ellipticalCopulaFit Fits the paramter of an elliptical copula ellipticalCopulaSim <- function (n, rho = 0.75, param = NULL, type = c("norm", "cauchy", "t")) { # A function implemented by Diethelm Wuertz # Description: # Simulates bivariate elliptical Copula # Match Arguments: type = match.arg(type) # "norm" Random Deviates: if (type == "norm") { ans = .rnormCopula(n = n, rho = rho) } # "cauchy" Random Deviates: if (type == "cauchy") { ans = .rcauchyCopula(n = n, rho = rho) } # "t" Random Deviates: if (type == "t") { if (is.null(param)) { param = c(nu = 4) } else { param = c(nu = param[1]) } ans = .rtCopula(n = n, rho = rho, nu = param) } # "logistic" Random Deviates: # NOT YET IMPLEMENTED ... # "laplace" Random Deviates: # NOT YET IMPLEMENTED ... # "kotz" Random Deviates: # NOT YET IMPLEMENTED ... # "epower" Random Deviates: # NOT YET IMPLEMENTED ... # Control: control = list(rho = rho, param = param, type = type) attr(ans, "control") = unlist(control) # Return Value: ans } # ------------------------------------------------------------------------------ ellipticalCopulaFit <- function(u, v = NULL, type = c("norm", "cauchy", "t"), ...) { # A function implemented by Diethelm Wuertz # Description: # Fits the paramter of an elliptical copula # Note: # The upper limit for nu is 100 # FUNCTION: # Match Arguments: type = match.arg(type) # Settings: U = u V = v if (is.list(u)) { u = u[[1]] v = u[[2]] } if (is.matrix(u)) { U = u[, 1] V = u[, 2] } U <<- u V <<- v # Estimate Rho from Kendall's tau for all types of Copula: tau = cor(x = U, y = V, method = "kendall") #[1, 2] Rho = rho = sin((pi*tau/2)) # Specify Bounds to be < and > instead of <= and >= upper <- 1-.Machine$double.eps lower <- -upper # Estimate "norm" Copula: if (type == "norm") { fun = function(x) { -mean( log(.dnormCopula(u = U, v = V, rho = x)) ) } fit = nlminb(start = rho, objective = fun, lower = lower, upper = upper, control = list(trace=TRUE), ...) } # Estimate "cauchy" Copula: if (type == "cauchy") { fun = function(x) { -mean( log(.dcauchyCopula(u = U, v = V, rho = x)) ) } fit = nlminb(start = rho, objective = fun, lower = lower, upper = upper, ...) } # Estimate "t" Copula: if (type == "t") { fun = function(x) { -mean( log(.dtCopula(u = U, v = V, rho = x[1], nu = x[2])) ) } fit = nlminb(start = c(rho = rho, nu = 4), objective = fun, lower = c(lower, upper), upper = c(upper, Inf), ...) fit$Nu = 4 } # Estimate "logistic" Copula: if (type == "logistic") { # NOT YET IMPLEMENTED ... fun = function(x) { -mean( log(dellipticalCopula(u = U, v = V, ...)) ) } fit = nlminb(start = c(), objective = fun, lower = c(rho = lower, NA), upper = c(rho = upper, NA), ...) } # Estimate "laplace" Copula: if (type == "laplace") { # NOT YET IMPLEMENTED ... fun = function(x) { -mean( log(dellipticalCopula(u = U, v = V, ...)) ) } fit = nlminb(start = c(), objective = fun, lower = c(rho = lower, NA), upper = c(rho = upper, NA), ...) } # Estimate "kotz" Copula: if (type == "kotz") { # NOT YET IMPLEMENTED ... fun = function(x) { -mean( log(dellipticalCopula(u = U, v = V, ...)) ) } fit = nlminb(start = c(), objective = fun, lower = c(rho = lower, NA), upper = c(rho = upper, NA), ...) } # Estimate "epower" Copula: if (type == "epower") { # NOT YET IMPLEMENTED ... fun = function(x) { -mean( log(dellipticalCopula(u = U, v = V, ...)) ) } fit = nlminb(start = c(), objective = fun, lower = c(rho = lower, NA), upper = c(rho = upper, NA), ...) } # Keep Start Value: # fit$Rho = Rho # Return Value: fit } ################################################################################ fCopulae/R/ExtremeValueGenerator.R0000644000176000001440000006046312406047540016654 0ustar ripleyusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA ################################################################################ # FUNCTION: EXTREME VALUE COPULAE PARAMETER: # evList Returns list of implemented extreme value copulae # evParam Sets Default parameters for an extreme value copula # evCheck Checks if parameters are in the valid range # evRange Returns the range of valid parameter values # FUNCTION: EXTREME VALUE COPULAE GENERATOR FUNCTION: # Afunc Computes Dependence function # AfuncSlider Displays interactively dependence function # .AfuncFirstDer Computes Derivative of dependence function # .AfuncSecondDer Computes 2nd Derivative of dependence function ################################################################################ ################################################################################ # FUNCTION: EXTREME VALUE COPULAE PARAMETER: # evList Returns list of implemented extreme value copulae # evParam Sets parameters for an extreme value copula # evRange Returns the range of valid parameter values # evCheck Checks if parameters are in the valid range evList = function() { # A function implemented by Diethelm Wuertz # Description: # Returns list of implemented extreme value copulae # Compose List: ans = c("gumbel", "galambos", "husler.reiss", "tawn", "bb5") # Return Value: ans } # ------------------------------------------------------------------------------ evParam = function(type = evList()) { # A function implemented by Diethelm Wuertz # Description: # Sets default parameters for extreme value copulae # Arguments: # type - a character string naming the copula. By default the # "gumbel" copula will be chosen. # Value: # returns a list with two elements, 'param' sets the parameters # which may be a vector, 'range' the range with minimum and # maximum values for each of the parameters. For the "pi" and # "m" copula NULL will be returned. # FUNCTION: # Settings: type = match.arg(type) ans = list(copula = type) # Select: if ( type == "gumbel" ) { ans$param = c(delta = 2) ans$range = c(1, Inf) } if ( type == "galambos" ) { ans$param = c(delta = 2) ans$range = c(0, Inf) } if ( type == "husler.reiss" ) { ans$param = c(delta = 2) ans$range = c(0, Inf) } if ( type == "tawn" ) { ans$param = c(alpha = 2, beta = 1/2, r = 2) ans$range = c(0, 1, 0, 1, 1, Inf) } if ( type == "bb5" ) { ans$param = c(delta = 2, theta = 2) ans$range = c(0, Inf, 0, Inf) } # Some more, yet untested and undocumented: if ( type == "gumbelII" ) { ans$param = c(alpha = 2) ans$range = NULL } if ( type == "marshall.olkin" ) { ans$param = c(alpha1 = 2, alpha2 = 2) ans$range = NULL } if ( type == "pi" ) { ans$param = NULL ans$range = NULL } if ( type == "m" ) { ans$param = NULL ans$range = NULL } # Return Value: ans } # ------------------------------------------------------------------------------ evRange = function(type = evList()) { # A function implemented by Diethelm Wuertz # Description: # Returns the range of valid parameter values # Examples: # evRange("galambos") # evRange("bb5") # FUNCTION: # Type: type = match.arg(type) # Range: ans = evParam(type)$range Names1 = rep(c("lower", "upper"), times = length(ans)/2) Names2 = rep(names(evParam(type)$param), each = 2) names(ans) = paste(Names1, Names2, sep = ".") attr(ans, "control")<-type # Return Value: ans } # ------------------------------------------------------------------------------ evCheck = function(param, type = evList()) { # A function implemented by Diethelm Wuertz # Description: # Checks if parameters are in the valid range # FUNCTION: # Type: type = match.arg(type) # Check range = evRange(type) nParam = length(range)/2 j = -1 J = 0 for (i in 1:nParam) { j = j + 2 J = J + 2 if (param[i] < range[j] | param[i] > range[J]) { print(c(param = param[i])) print(c(range = c(range[j], range[J]))) stop("param is out of range") } } # Return Value: invisible(TRUE) } ################################################################################ # FUNCTION: EXTREME VALUE COPULAE GENERATOR FUNCTION: # Afunc Computes Dependence function # AfuncSlider Displays interactively dependence function # .AfuncFirstDer Computes Derivative of dependence function # .AfuncSecondDer Computes 2nd Derivative of dependence function Afunc = function(x, param = NULL, type = evList()) { # A function implemented by Diethelm Wuertz # Description: # Computes dependence function for extreme value copulae # Arguments: # x - a numeric vector, with values ranging between # zero and one # param - numeric parameter vector, if set to NULL then # default values are taken # type - character string naming the type of copula, # by default "gumbel" # Details: # Extreme Value Copulae can be represented in the form # # C(u,v) = exp { log(uv)*A[log(u)/log(uv)] } # # where A:[0,1] -> [1/2,1] is a convex function # such that max(x,1-x) < A(x) < 1 for all x in [0,1]. # Notes: # Copulae included also in EVANESCE: # gumbel, galambos, husler.reiss, tawn, bb5 # Additionally - not yet tested and documented # gumbelII, marshall.olkin, pi[Cperp], m[Cplus] # References: # Bouye E. (2000), Copulas for Finance: A Reading Guide and # Some Applications, (see the Table on page 49). # Insightful Corp, EVANESCE Implementation in S-PLUS # FinMetrics Module. # FUNCTION: # Missing x: if (missing(x)) x = (0:10)/10 # Type: type = type[1] if (is.null(param)) param = evParam(type)$param names(param) = names(evParam(type)$param) # Compute Dependence Function: if (type == "gumbel") { # 1 <= alpha < Inf alpha = param[1] if (alpha == 1) A = rep(1, times = length(x)) else A = (x^alpha + (1-x)^alpha)^(1/alpha) } if (type == "galambos") { # 0 <= alpha < Inf alpha = param[1] A = 1 - (x^(-alpha) + (1-x)^(-alpha))^(-1/alpha) } if (type == "husler.reiss") { # 0 <= alpha <= Inf alpha = param[1] A = x * pnorm(1/alpha + 0.5*alpha*log(x/(1-x))) + (1-x) * pnorm(1/alpha - 0.5*alpha*log(x/(1-x))) } if (type == "tawn") { # 0 <= alpha <=1 # 0 <= beta <= 1 # 1 <= r < Inf alpha = param[1] beta = param[2] r = param[3] if (alpha == 0 | beta == 0 | r == 1) A = rep(1, times = length(x)) else A = 1 - beta +(beta-alpha)*x + ( (alpha*x)^r + (beta*(1-x))^r )^(1/r) } if (type == "bb5") { # 0 < delta < Inf # 1 <= theta Inf delta = param[1] theta = param[2] if (theta == 1) return(Afunc(x, param, "galambos")) else A = ( x^theta + (1-x)^theta - ( x^(-delta*theta) + (1-x)^(-delta*theta) )^(-1/delta))^(1/theta) } # Some more, yet untested and undocumented: if (type == "gumbelII") { # 0 <= alpha < Inf alpha = param[1] A = alpha*x^2 - alpha*x + 1 } if (type == "marshall.olkin") { alpha1 = param[1] alpha2 = param[2] A = NULL for (i in 1:length(x)) A = c(A, max(1-alpha1*x[i], 1-alpha2*(1-x[i]))) } if (type == "pi" || type == "Cperp") { # No parameters A = rep(1, times = length(x)) } if (type == "m" || type == "Cplus") { # No parameters A = NULL for (i in 1:length(x)) A = c(A, max(x[i], 1-x[i])) } # Result: attr(A, "control") <- unlist(list(param = param, type = type)) # Return Value: A } # ------------------------------------------------------------------------------ AfuncSlider = function() { # A function implemented by Diethelm Wuertz # Description: # Displays interactively the dependence function # Graphic Frame: par(mfrow = c(2, 2), cex = 0.7) # Internal Function: refresh.code = function(...) { # Startup Counter: .counter <- getRmetricsOptions(".counter") + 1 setRmetricsOptions(.counter = .counter) if (.counter < 10) return () # Sliders: Type = evList() Copula = .sliderMenu(no = 1) N = .sliderMenu(no = 2) if (Copula <= 3) param = c(delta = .sliderMenu(no = Copula + 2)) if (Copula == 4) param = c(alpha = .sliderMenu(no = 6), beta = .sliderMenu(no = 7), r = .sliderMenu(no = 8)) if (Copula == 5) param = c(delta = .sliderMenu(no = 9), theta = .sliderMenu(no = 10)) # Title: type = Type[Copula] subTitle = paste(paste(names(param) , "="), param, collapse = " | " ) Title = paste(" ", type, "\n", subTitle) # Plot A: plot(x = (0:N)/N, Afunc(x = (0:N)/N, param = param, type = type), ylim = c(0.5, 1), type = "l", xlab = "x", ylab = "A", main = Title) lines(c(0.0, 1.0), c(1.0, 1.0), col = "steelblue", lty = 3) lines(c(0.0, 0.5), c(1.0, 0.5), col = "steelblue", lty = 3) lines(c(0.5, 1.0), c(0.5, 1.0), col = "steelblue", lty = 3) points(x = c(0, 1), Afunc(x = c(0, 1), param = param, type = type), col = "red") # Plot A': plot(x = (0:N)/N, .AfuncFirstDer(x = (0:N)/N, param = param, type = type), type = "l", xlab = "x", ylab = "A'", main = Title) points(x = c(0, 1), .AfuncFirstDer(x = c(0, 1), param = param, type = type), col = "red") # Plot A'': plot(x = (0:N)/N, .AfuncSecondDer(x = (0:N)/N, param = param, type = type), type = "l", xlab = "x", ylab = "A''", main = Title) points(x = c(0, 1), .AfuncSecondDer(x = c(0, 1), param = param, type = type), col = "red") # Reset Frame: par(mfrow = c(2, 2), cex = 0.7) } # Open Slider Menu: setRmetricsOptions(.counter = 0) C = c("Gumbel: delta", "Galambos: delta", "Husler-Reis: delta", "Tawn: alpha", "... beta", "... r", "BB5: delta", "... theta") .sliderMenu(refresh.code, names = c("Copula", "N", C), #gal hr tawn bb5 minima = c(1, 100, 1.0, 0.00, 0.00, 0.00, 0.00, 1.0, 0.0, 1.0), maxima = c(5, 10000, 10.0, 10.0, 10.0, 1.00, 1.00, 10., 10., 10.), resolutions = c(1, 100, 0.05, 0.05, 0.05, 0.01, 0.01, 0.1, 0.1, 0.1), starts = c(1, 5000, 1.00, 0.00, 0.00, 0.00, 0.00, 1.0, 0.0, 1.0)) } # ------------------------------------------------------------------------------ .AfuncFirstDer = function(x, param = NULL, type = evList(), eps = 1.0e-6 ) { # A function implemented by Diethelm Wuertz # Description: # # Computes derivaive of dependence function # Arguments: # x - a numeric vector, with values ranging between # zero and one # param - numeric parameter vector, if set to NULL then # default values are taken # type - character string naming the type of copula, # by default "gumbel" # Details: # Extreme Value Copulae can be represented in the form # # C(u,v) = exp { log(uv)*A[log(u)/log(uv)] } # # where A:[0,1] -> [1/2,1] is a convex function # such that max(x,1-x) < A(x) < 1 for all x in [0,1]. # Notes: # Copulae included also in EVANESCE: # gumbel, galambos, husler.reiss, tawn, bb5 # Additionally - not yet tested and documented # gumbelII, marshall.olkin, pi[Cperp], m[Cplus] # References: # Bouye E. (2000), Copulas for Finance: A Reading Guide and # Some Applications, (see the Table on page 49). # Insightful Corp, EVANESCE Implementation in S-PLUS # FinMetrics Module. # FUNCTION: # Missing x: if (missing(x)) x = (0:10)/10 # Type: type = type[1] if (is.null(param)) param = evParam(type)$param names(param) = names(evParam(type)$param) # Settings for Maple Output: Pi = pi ln = function(x) { log(x) } erf = function (x) { 2*pnorm(sqrt(2)*x)-1 } # Compute Derivative: if (type == "gumbel") { # alpha >= 1 alpha = param[1] # Maple Generated Output: if (alpha == 1) A1 = rep(0, times = length(x)) else { A1 = (x^alpha+(1-x)^alpha)^(1/alpha)/alpha*(x^alpha*alpha/x-(1-x)^alpha* alpha/(1-x))/(x^alpha+(1-x)^alpha) A1[x < eps] = -1 A1[x > 1-eps] = 1 } } if (type == "galambos") { # 0 <= alpha < Inf alpha = param[1] # Maple Generated Output: if (alpha == 0) A1 = rep(1, times = length(x)) else { A1 = (x^(-alpha)+(1-x)^(-alpha))^(-1/alpha)/alpha*(-x^(-alpha)*alpha/x+( 1-x)^(-alpha)*alpha/(1-x))/(x^(-alpha)+(1-x)^(-alpha)) A1[x < eps] = -1 A1[x > 1-eps] = 1 } } if (type == "husler.reiss") { # 0 <= alpha <= Inf alpha = param[1] # Maple Generated Output: if (alpha == 0) A1 = rep(1, times = length(x)) else { A1 = .5*erf(1/2*(1/alpha+.5*alpha*ln(x/(1-x)))*2^(1/2))+.2500000000/Pi^( 1/2)*exp(-1/2*(1/alpha+.5*alpha*ln(x/(1-x)))^2)*alpha*(1/(1-x)+x/(1 -x)^2)*(1-x)*2^(1/2)-.5*erf(1/2*(1/alpha-.5*alpha*ln(x/(1-x)))*2^(1 /2))-.2500000000*(1-x)^2/Pi^(1/2)*exp(-1/2*(1/alpha-.5*alpha*ln(x/( 1-x)))^2)*alpha*(1/(1-x)+x/(1-x)^2)/x*2^(1/2) A1[x < eps] = -1 A1[x > 1-eps] = 1 } } if (type == "tawn") { # 0 <= alpha < Inf # beta <= 1 # 1 <= r < Inf alpha = param[1] beta = param[2] r = param[3] # Maple Generated Output: if (alpha == 0 | beta == 0 | r == 1) A1 = rep(0, length(x)) else { A1 = beta-alpha+((alpha*x)^r+(beta*(1-x))^r)^(1/r)/r*((alpha*x)^r*r/x-( beta*(1-x))^r*r/(1-x))/((alpha*x)^r+(beta*(1-x))^r) A1[x < eps] = -alpha A1[x > 1-eps] = beta } } if (type == "bb5") { # 0 < delta < Inf # 1 <= theta < Inf delta = param[1] theta = param[2] # Maple Generated Output: if (theta == 1) return(.AfuncFirstDer(x, param, "galambos")) else A1 = (x^theta+(1-x)^theta-(x^(-delta*theta)+(1-x)^(-delta*theta))^(-1/ delta))^(1/theta)/theta*(x^theta*theta/x-(1-x)^theta*theta/(1-x)+(x ^(-delta*theta)+(1-x)^(-delta*theta))^(-1/delta)/delta*(-x^(-delta* theta)*delta*theta/x+(1-x)^(-delta*theta)*delta*theta/(1-x))/(x^(- delta*theta)+(1-x)^(-delta*theta)))/(x^theta+(1-x)^theta-(x^(-delta *theta)+(1-x)^(-delta*theta))^(-1/delta)) A1[x < eps] = -1 A1[x > 1-eps] = 1 } # Some more, yet untested and undocumented: if (type == "gumbelII") { # 0 <= alpha < Inf alpha = param[1] A1 = 2*alpha*x-alpha } if (type == "marshall.olkin") { alpha1 = param[1] alpha2 = param[2] A1 = NULL for (i in 1:length(x)) { if (x[i] < 0) A1 = c(A1, -alpha1) if (x[i] > 0) A1 = c(A1, alpha2) if (x[i] == 0) A1 = c(A1, NA) } } if (type == "pi" || type == "Cperp") { A1 = rep(0, times = length(x)) } if (type == "m" || type == "Cplus") { A1 = sign(x-1/2) } # Result: attr(A1, "control") <- unlist(list(param = param, type = type)) # Return Value: A1 } # ------------------------------------------------------------------------------ .AfuncSecondDer = function(x, param = NULL, type = evList()) { # A function implemented by Diethelm Wuertz # Description: # Computes 2nd derivative of dependence function # Arguments: # x - a numeric vector, with values ranging between # zero and one # param - numeric parameter vector, if set to NULL then # default values are taken # type - character string naming the type of copula, # by default "gumbel" # Details: # Extreme Value Copulae can be represented in the form # # C(u,v) = exp { log(uv)*A[log(u)/log(uv)] } # # where A:[0,1] -> [1/2,1] is a convex function # such that max(x,1-x) < A(x) < 1 for all x in [0,1]. # Note: # The five Copulae considered in EVANESCE are: # gumbel, galambos, husler.reis, tawn, bb5 # Furthermore, added are: # pi|Cperp, gumbelII, marshall.olkin, m|Cplus # References: # Bouye E. (2000), Copulas for Finance: A Reading Guide and # Some Applications, (see the Table on page 49). # Insightful Corp, EVANESCE Implementation in S-PLUS # FinMetrics Module. # FUNCTION: # Missing x: if (missing(x)) x = (0:10)/10 # Type: type = type[1] if (is.null(param)) param = evParam(type)$param names(param) = names(evParam(type)$param) # Settings for Maple Output: Pi = pi ln = function(x) { log(x) } erf = function (x) { 2*pnorm(sqrt(2)*x)-1 } # Compute 2nd Derivative: if (type == "gumbel") { # alpha >= 1 alpha = param[1] # Maple Generated Output: if (alpha == 1) A2 = rep(0, times = length(x)) else A2 = (x^alpha+(1-x)^alpha)^(1/alpha)/alpha^2*(x^alpha*alpha/x-(1-x)^ alpha*alpha/(1-x))^2/(x^alpha+(1-x)^alpha)^2+(x^alpha+(1-x)^alpha)^ (1/alpha)/alpha*(x^alpha*alpha^2/x^2-x^alpha*alpha/x^2+(1-x)^alpha* alpha^2/(1-x)^2-(1-x)^alpha*alpha/(1-x)^2)/(x^alpha+(1-x)^alpha)-(x ^alpha+(1-x)^alpha)^(1/alpha)/alpha*(x^alpha*alpha/x-(1-x)^alpha* alpha/(1-x))^2/(x^alpha+(1-x)^alpha)^2 } if (type == "galambos") { # 0 <= alpha < Inf alpha = param[1] # Maple Generated Output: if (alpha == 0) A2 = rep(0, times = length(x)) else if (alpha == 1) A2 = rep(2, times = length(x)) else A2 = -(x^(-alpha)+(1-x)^(-alpha))^(-1/alpha)/alpha^2*(-x^(-alpha)*alpha/ x+(1-x)^(-alpha)*alpha/(1-x))^2/(x^(-alpha)+(1-x)^(-alpha))^2+(x^(- alpha)+(1-x)^(-alpha))^(-1/alpha)/alpha*(x^(-alpha)*alpha^2/x^2+x^( -alpha)*alpha/x^2+(1-x)^(-alpha)*alpha^2/(1-x)^2+(1-x)^(-alpha)* alpha/(1-x)^2)/(x^(-alpha)+(1-x)^(-alpha))-(x^(-alpha)+(1-x)^(- alpha))^(-1/alpha)/alpha*(-x^(-alpha)*alpha/x+(1-x)^(-alpha)*alpha/ (1-x))^2/(x^(-alpha)+(1-x)^(-alpha))^2 } if (type == "husler.reiss") { # 0 <= alpha <= Inf alpha = param[1] # Maple Generated Output: if (alpha == 0) A2 = rep(0, times = length(x)) else A2 = .2500000000/Pi^(1/2)*exp(-1/2*(1/alpha+.5*alpha*ln(x/(1-x)))^2)* alpha*(1/(1-x)+x/(1-x)^2)/x*(1-x)*2^(1/2)-.1250000000/Pi^(1/2)*(1/ alpha+.5*alpha*ln(x/(1-x)))*alpha^2*(1/(1-x)+x/(1-x)^2)^2/x*(1-x)^2* exp(-1/2*(1/alpha+.5*alpha*ln(x/(1-x)))^2)*2^(1/2)+.2500000000/Pi^( 1/2)*exp(-1/2*(1/alpha+.5*alpha*ln(x/(1-x)))^2)*alpha*(2/(1-x)^2+2 *x/(1-x)^3)*(1-x)*2^(1/2)-.2500000000/Pi^(1/2)*exp(-1/2*(1/alpha+.5 *alpha*ln(x/(1-x)))^2)*alpha*(1/(1-x)+x/(1-x)^2)*2^(1/2)+.75000000/ Pi^(1/2)*exp(-1/2*(1/alpha-.5*alpha*ln(x/(1-x)))^2)*alpha*(1/(1-x )+x/(1-x)^2)/x*(1-x)*2^(1/2)-.1250000000*(1-x)^3/Pi^(1/2)*(1/alpha- .5*alpha*ln(x/(1-x)))*alpha^2*(1/(1-x)+x/(1-x)^2)^2/x^2*exp(-1/2*(1 /alpha-.5*alpha*ln(x/(1-x)))^2)*2^(1/2)-.2500000000*(1-x)^2/Pi^(1/2 )*exp(-1/2*(1/alpha-.5*alpha*ln(x/(1-x)))^2)*alpha*(2/(1-x)^2+2*x/( 1-x)^3)/x*2^(1/2)+.2500000000*(1-x)^2/Pi^(1/2)*exp(-1/2*(1/alpha-.5* alpha*ln(x/(1-x)))^2)*alpha*(1/(1-x)+x/(1-x)^2)/x^2*2^(1/2) } if (type == "tawn") { # 0 <= alpha, beta <= 1, 1 <= r < Inf alpha = param[1] beta = param[2] r = param[3] # Maple Generated Output: if (alpha == 0 | beta == 0 | r == 1) A2 = rep(0, length(x)) else A2 = ((alpha*x)^r+(beta*(1-x))^r)^(1/r)/r^2*((alpha*x)^r*r/x-(beta*(1-x) )^r*r/(1-x))^2/((alpha*x)^r+(beta*(1-x))^r)^2+((alpha*x)^r+(beta*(1 -x))^r)^(1/r)/r*((alpha*x)^r*r^2/x^2-(alpha*x)^r*r/x^2+(beta*(1-x)) ^r*r^2/(1-x)^2-(beta*(1-x))^r*r/(1-x)^2)/((alpha*x)^r+(beta*(1-x))^ r)-((alpha*x)^r+(beta*(1-x))^r)^(1/r)/r*((alpha*x)^r*r/x-(beta*(1-x ))^r*r/(1-x))^2/((alpha*x)^r+(beta*(1-x))^r)^2 # A2[x<1e-12] = 0 # A2[x>1-1e-12] = 0 } if (type == "bb5") { # delta > 0, theta >= 1 delta = param[1] theta = param[2] # Maple Generated Output: if (theta == 1) return(.AfuncSecondDer(x, param, "galambos")) else A2 = (x^theta+(1-x)^theta-(x^(-delta*theta)+(1-x)^(-delta*theta))^(-1/ delta))^(1/theta)/theta^2*(x^theta*theta/x-(1-x)^theta*theta/(1-x)+ (x^(-delta*theta)+(1-x)^(-delta*theta))^(-1/delta)/delta*(-x^(- delta*theta)*delta*theta/x+(1-x)^(-delta*theta)*delta*theta/(1-x))/ (x^(-delta*theta)+(1-x)^(-delta*theta)))^2/(x^theta+(1-x)^theta-(x^ (-delta*theta)+(1-x)^(-delta*theta))^(-1/delta))^2+(x^theta+(1-x)^ theta-(x^(-delta*theta)+(1-x)^(-delta*theta))^(-1/delta))^(1/theta)/ theta*(x^theta*theta^2/x^2-x^theta*theta/x^2+(1-x)^theta*theta^2/( 1-x)^2-(1-x)^theta*theta/(1-x)^2-(x^(-delta*theta)+(1-x)^(-delta* theta))^(-1/delta)/delta^2*(-x^(-delta*theta)*delta*theta/x+(1-x)^( -delta*theta)*delta*theta/(1-x))^2/(x^(-delta*theta)+(1-x)^(-delta* theta))^2+(x^(-delta*theta)+(1-x)^(-delta*theta))^(-1/delta)/delta* (x^(-delta*theta)*delta^2*theta^2/x^2+x^(-delta*theta)*delta*theta/ x^2+(1-x)^(-delta*theta)*delta^2*theta^2/(1-x)^2+(1-x)^(-delta* theta)*delta*theta/(1-x)^2)/(x^(-delta*theta)+(1-x)^(-delta*theta)) -(x^(-delta*theta)+(1-x)^(-delta*theta))^(-1/delta)/delta*(-x^(- delta*theta)*delta*theta/x+(1-x)^(-delta*theta)*delta*theta/(1-x))^ 2/(x^(-delta*theta)+(1-x)^(-delta*theta))^2)/(x^theta+(1-x)^theta-( x^(-delta*theta)+(1-x)^(-delta*theta))^(-1/delta))-(x^theta+(1-x)^ theta-(x^(-delta*theta)+(1-x)^(-delta*theta))^(-1/delta))^(1/theta)/ theta*(x^theta*theta/x-(1-x)^theta*theta/(1-x)+(x^(-delta*theta)+( 1-x)^(-delta*theta))^(-1/delta)/delta*(-x^(-delta*theta)*delta* theta/x+(1-x)^(-delta*theta)*delta*theta/(1-x))/(x^(-delta*theta)+( 1-x)^(-delta*theta)))^2/(x^theta+(1-x)^theta-(x^(-delta*theta)+(1-x )^(-delta*theta))^(-1/delta))^2 } # Some more, yet untested and undocumented: if (type == "gumbelII") { alpha = param[1] A2 = rep(2*alpha, times = length(x)) } if (type == "marshall.olkin") { alpha1 = param[1] alpha2 = param[2] A2 = rep(0, times = length(x)) } if (type == "pi" || type == "Cperp") { A2 = rep(0, times = length(x)) } if (type == "m" || type == "Cplus") { A2 = rep(0, times = length(x)) } # Result: attr(A2, "control") <- unlist(list(param = param, type = type)) # Return Value: A2 } ################################################################################ fCopulae/R/ArchimedeanSlider.R0000644000176000001440000005664212406047540015746 0ustar ripleyusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA ################################################################################ # FUNCTION: ARCHIMEDEAN COPULAE SLIDERS: # rarchmSlider Displays interactively Archimedean probability # parchmSlider Displays interactively Archimedean probability # .parchmPerspSlider Perspective Archimedean probability slider # .parchmContourSlider Contour Archimedean probability slider # darchmSlider Displays interactively archimedean density # .darchmPerspSlider Perspective Archimedean density slider # .darchmContourSlider Contour Archimedean density slider ################################################################################ ################################################################################ rarchmSlider <- function(B = 10) { # A function implemented by Diethelm Wuertz # Description: # Displays interactively perspective plots of probability # FUNCTION: # Graphic Frame: par(mfrow = c(1, 1)) # Internal Function: refresh.code <- function(...) { # Sliders: # 1 5 10 15 20 Counter = c(1,2,3,2,4,2,5,2,5,5,6,2,7,2,2,7,4,8,7,7,2,5) Copula = as.integer(.sliderMenu(no = 1)) No = Counter[Copula] N = .sliderMenu(no = 2) alpha = .sliderMenu(no = No+2) # There is no known Copula for the following bounds: eps = 1.0e-6 if (Copula == 11) if (alpha == 0.5) alpha = 0.5 - eps if (Copula == 13) if (alpha == 0.0) alpha = eps # Title: Names = c( "- Clayton", "", "- Ali-Mikhail-Hag", "- Gumbel-Hougard", "- Frank", "- Joe-Frank", "", "", "- Gumbel-Barnett", "", "", "", "", "", "- Genest-Ghoudi", "", "", "", "", "", "", "") Title = paste("Archimedean Copula No:", as.character(Copula), Names[Copula], "\nalpha = ", as.character(alpha)) # Plot: R = rarchmCopula(n = N, alpha = alpha, type = as.character(Copula)) plot(R, xlab = "U", ylab = "V", pch = 19, col = "steelblue") grid() title(main = Title) # Reset Frame: par(mfrow = c(1, 1)) } # Open Slider Menu: C2 = "2-4-6-8-12-14-15-21" C = c("1", C2, "3", "5-17", "7-9-10-22", "11", "13-16-19-20","18") L = c( -1, 1, -1, -B, 0, 0, 0, 2 ) U = c( B, B, 1, B, 1, 0.5, B, B ) A = c(0.5, 2, 0.5, 1, 0.5, 0.2, 1, 3 ) V = rep(0.1, 8) .sliderMenu(refresh.code, names = c("Copula", "N", C), minima = c( 1, 100, L), maxima = c( 22, 1000, U), resolutions = c( 1, 100, V), starts = c( 1, 100, A)) } ################################################################################ parchmSlider <- function(type = c("persp", "contour"), B = 10) { # A function implemented by Diethelm Wuertz # Description: # Displays interactively plots of probability # Description: # Displays interactively plots of probability # Arguments: # type - a character string specifying the plot type. # Either a perspective plot which is the default or # a contour plot with an underlying image plot will # be created. # B - the maximum slider menu value when the boundary # value is infinite. By default this is set to 10. # FUNCTION: # Match Arguments: type = match.arg(type) # Plot: if (type[1] == "persp") .parchmPerspSlider(B = B) if (type[1] == "contour") .parchmContourSlider(B = B) # Return Value: invisible() } # ------------------------------------------------------------------------------ .parchmPerspSlider = function(B = 5) { # A function implemented by Diethelm Wuertz # Description: # Displays interactively perspective plots of probability # FUNCTION: # Graphic Frame: par(mfrow = c(1, 1)) # Internal Function: refresh.code = function(...) { # Sliders: Counter = c(1,2,3,2,4,2,5,2,5,5,6,2,7,2,2,7,4,8,7,7,2,5) Copula = as.integer(.sliderMenu(no = 1)) No = Counter[Copula] N = .sliderMenu(no = 2) alpha = .sliderMenu(no = No+2) theta = .sliderMenu(no = 11) phi = .sliderMenu(no = 12) # Skip: if (Copula == 11) if (alpha == 0.5) return(invisible()) if (Copula == 13) if (alpha == 0) return(invisible()) # Do we have a strict Copula? strict = c( "Yes","No","Yes","Yes","Yes","Yes","No","No","Yes","Yes", "No","Yes","Yes","Yes","No","Yes","Yes","No","Yes","Yes", "No","Yes")[Copula] if (alpha < 0 & Copula == 1) strict[1] = "No" if (alpha == 0 & Copula == 16) strict[16] = "No" # What is the Range? RANGE = c( "[-1|Inf)", "[1|Inf)", "[-1|1)", "(-Inf|Inf)", "(0|1]", "(0|0.5]", "(0|Inf)", "[2|Inf)")[No] # Which one is the Limit Copula? limitTitle = rep("NA", times = 22) if (alpha == -1) limitTitle = c( "W ", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "Pi", "NA", "NA", "NA", "NA", "NA") if (alpha == 0) limitTitle = c( "Pi", "NA", "Pi", "NA", "Pi", "NA", "W ", "NA", "Pi", "Pi", "Pi", "NA", "NA", "NA", "NA", "W ", "NA", "NA", "L ", "Pi", "NA", "Pi") if (alpha == 1) limitTitle = c( "L ", "W ", "L ", "Pi", "NA", "Pi", "Pi", "W ", "NA", "NA", "NA", "L ", "Pi", "L ", "W ", "NA", "NA", "NA", "NA", "NA", "W ", "NA") limitTitle = limitTitle[Copula] if (limitTitle == "NA") { limitTitle = " " } else { limitTitle = paste(" Copula = ", limitTitle[1]) } # Tau/Rho: Tau = round(approx(.ALPHA[, Copula], .TAU[, Copula], xout = alpha)$y, digits = 3) Rho = round(approx(.ALPHA[, Copula], .RHO[, Copula], xout = alpha)$y, digits = 3) # Title: Names = c( "- Clayton", "", "- Ali-Mikhail-Hag", "- Gumbel-Hougard", "- Frank", "- Joe-Frank", "", "", "- Gumbel-Barnett", "", "", "", "", "", "- Genest-Ghoudi", "", "", "", "", "", "", "") Title = paste("Archimedean Copula No:", as.character(Copula), Names[Copula], "\n", RANGE, " alpha =", as.character(alpha), " tau =", as.character(Tau), " rho =", as.character(Rho)) # Plot: uv = grid2d(x = (0:N)/N) P = .parchm1Copula(u = uv, alpha = alpha, type = Copula, output = "list") persp(P, theta = theta, phi = phi, col = "steelblue", shade = 0.5, ticktype = "detailed", cex = 0.5, xlab = "u", ylab = "v", zlab = "C(u,v)" ) title(main = Title) # Reset Frame: par(mfrow = c(1, 1)) } # Open Slider Menu: B = 5 C1 = "1: [-1,Inf]" C2 = "2-4-6-8-12-14-15-21: [1,Inf)" C3 = "3: [-1,1)" C4 = "5-17: (-Inf,Inf)|{0}" C5 = "7-9-10-22: (0,1]" C6 = "11: (0, 1/2]" C7 = "13-16-19-20: (0,Inf)" C8 = "18: [2, Inf)" C = c( C1, C2, C3, C4, C5, C6, C7, C8 ) L = c( -1, 1, -1, -B, 0, 0, 0, 2 ) U = c( B, B, 1, B, 1, 0.5, B, B ) A = c( 0.5, 2, 0.5, 1, 0.5, 0.2, 1, 3 ) V = rep(0.01, 8) plot.names = c("Plot - theta", "... phi") .sliderMenu(refresh.code, names = c("Copula", "N", C, plot.names), minima = c( 1, 10, L, -180, 0), maxima = c( 22, 100, U, 180, 360), resolutions = c( 1, 10, V, 1, 1), starts = c( 1, 10, A, -40, 30)) } # ------------------------------------------------------------------------------ .parchmContourSlider <- function(B = 5) { # A function implemented by Diethelm Wuertz # Description: # Displays interactively perspective plots of probability #FUNCTION: # Graphic Frame: par(mfrow = c(1, 1)) # Internal Function: refresh.code = function(...) { # Sliders: # 1 5 10 15 20 Counter = c(1,2,3,2,4,2,5,2,5,5,6,2,7,2,2,7,4,8,7,7,2,5) Copula = as.integer(.sliderMenu(no = 1)) No = Counter[Copula] N = .sliderMenu(no = 2) alpha = .sliderMenu(no = No+2) n.lev = .sliderMenu(no = 11) n.col = .sliderMenu(no = 12) # Skip: if (Copula == 11) if (alpha == 0.5) return(invisible()) if (Copula == 13) if (alpha == 0) return(invisible()) # Do we have a strict Copula? strict = c( "Yes","No","Yes","Yes","Yes","Yes","No","No","Yes","Yes", "No","Yes","Yes","Yes","No","Yes","Yes","No","Yes","Yes", "No","Yes")[Copula] if (alpha < 0 & Copula == 1) strict[1] = "No" if (alpha == 0 & Copula == 16) strict[16] = "No" # What is the Range? RANGE = c( "[-1|Inf)", "[1|Inf)", "[-1|1)", "(-Inf|Inf)", "(0|1]", "(0|0.5]", "(0|Inf)", "[2|Inf)")[No] # Which one is the Limit Copula? limitTitle = rep("NA", times = 22) if (alpha == -1) limitTitle = c( "W ", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "Pi", "NA", "NA", "NA", "NA", "NA") if (alpha == 0) limitTitle = c( "Pi", "NA", "Pi", "NA", "Pi", "NA", "W ", "NA", "Pi", "Pi", "Pi", "NA", "NA", "NA", "NA", "W ", "NA", "NA", "L ", "Pi", "NA", "Pi") if (alpha == 1) limitTitle = c( "L ", "W ", "L ", "Pi", "NA", "Pi", "Pi", "W ", "NA", "NA", "NA", "L ", "Pi", "L ", "W ", "NA", "NA", "NA", "NA", "NA", "W ", "NA") limitTitle = limitTitle[Copula] if (limitTitle == "NA") { limitTitle = " " } else { limitTitle = paste(" Copula = ", limitTitle[1]) } # Tau/Rho: Tau = round(approx(.ALPHA[, Copula], .TAU[, Copula], xout = alpha)$y, digits = 3) Rho = round(approx(.ALPHA[, Copula], .RHO[, Copula], xout = alpha)$y, digits = 3) # Title: Names = c( "- Clayton", "", "- Ali-Mikhail-Hag", "- Gumbel-Hougard", "- Frank", "- Joe-Frank", "", "", "- Gumbel-Barnett", "", "", "", "", "", "- Genest-Ghoudi", "", "", "", "", "", "", "") Title = paste("Archimedean Copula No:", as.character(Copula), Names[Copula], "\n", RANGE, " alpha =", as.character(alpha), " tau =", as.character(Tau), " rho =", as.character(Rho)) # Plot: uv = grid2d(x = (0:N)/N) P = .parchm1Copula(u = uv, alpha = alpha, type = Copula, output = "list") image(P, col = heat.colors(n.col) ) contour(P, xlab = "u", ylab = "v", nlevels = n.lev, add = TRUE) title(main = Title) # Reset Frame: par(mfrow = c(1, 1)) } # Open Slider Menu: C1 = "1: [-1,Inf]" C2 = "2-4-6-8-12-14-15-21: [1,Inf)" C3 = "3: [-1,1)" C4 = "5-17: (-Inf,Inf)|{0}" C5 = "7-9-10-22: (0,1]" C6 = "11: (0, 1/2]" C7 = "13-16-19-20: (0,Inf)" C8 = "18: [2, Inf)" C = c( C1, C2, C3, C4, C5, C6, C7, C8 ) L = c( -1, 1, -1, -B, 0, 0, 0, 2 ) U = c( B, B, 1, B, 1, 0.5, B, B ) A = c( 0.5, 2, 0.5, 1, 0.5, 0.2, 1, 3 ) V = rep(0.01, 8) plot.names = c("Plot - levels", "... colors") .sliderMenu(refresh.code, names = c("Copula", "N", C, plot.names), minima = c( 1, 10, L, 5, 12), maxima = c( 20, 100, U, 100, 256), resolutions = c( 1, 10, V, 5, 1), starts = c( 1, 10, A, 10, 12)) } ################################################################################ darchmSlider <- function(type = c("persp", "contour"), B = 10) { # A function implemented by Diethelm Wuertz # Description: # Displays interactively plots of density # Arguments: # type - a character string specifying the plot type. # Either a perspective plot which is the default or # a contour plot with an underlying image plot will # be created. # B - the maximum slider menu value when the boundary # value is infinite. By default this is set to 10. # FUNCTION: # Match Arguments: type = match.arg(type) # Plot: if (type == "persp") .darchmPerspSlider(B = B) if (type == "contour") .darchmContourSlider(B = B) # Return Value: invisible() } # ------------------------------------------------------------------------------ .darchmPerspSlider <- function(B = 10) { # A function implemented by Diethelm Wuertz # Description: # Displays interactively perspective plots of density # FUNCTION: # Graphic Frame: par(mfrow = c(1, 1)) # Internal Function: refresh.code = function(...) { # Sliders: Counter = c(1,2,3,2,4,2,5,2,5,5,6,2,7,2,2,7,4,8,7,7,2,5) Copula = as.integer(.sliderMenu(no = 1)) No = Counter[Copula] N = .sliderMenu(no = 2) alpha = .sliderMenu(no = No+2) theta = .sliderMenu(no = 11) phi = .sliderMenu(no = 12) # Skip: if (Copula == 11) if (alpha == 0.5) return(invisible()) if (Copula == 13) if (alpha == 0) return(invisible()) # Do we have a strict Copula? strict = c( "Yes","No","Yes","Yes","Yes","Yes","No","No","Yes","Yes", "No","Yes","Yes","Yes","No","Yes","Yes","No","Yes","Yes", "No","Yes")[Copula] if (alpha < 0 & Copula == 1) strict[1] = "No" if (alpha == 0 & Copula == 16) strict[16] = "No" # What is the Range? RANGE = c( "[-1|Inf)", "[1|Inf)", "[-1|1)", "(-Inf|Inf)", "(0|1]", "(0|0.5]", "(0|Inf)", "[2|Inf)")[No] # Which one is the Limit Copula? limitTitle = rep("NA", times = 22) if (alpha == -1) limitTitle = c( "W ", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "Pi", "NA", "NA", "NA", "NA", "NA") if (alpha == 0) limitTitle = c( "Pi", "NA", "Pi", "NA", "Pi", "NA", "W ", "NA", "Pi", "Pi", "Pi", "NA", "NA", "NA", "NA", "W ", "NA", "NA", "L ", "Pi", "NA", "Pi") if (alpha == 1) limitTitle = c( "L ", "W ", "L ", "Pi", "NA", "Pi", "Pi", "W ", "NA", "NA", "NA", "L ", "Pi", "L ", "W ", "NA", "NA", "NA", "NA", "NA", "W ", "NA") limitTitle = limitTitle[Copula] if (limitTitle == "NA") { limitTitle = " " } else { limitTitle = paste(" Copula = ", limitTitle[1]) } # Tau/Rho: Tau = round(approx(.ALPHA[, Copula], .TAU[, Copula], xout = alpha)$y, digits = 3) Rho = round(approx(.ALPHA[, Copula], .RHO[, Copula], xout = alpha)$y, digits = 3) # Title: Names = c( "- Clayton", "", "- Ali-Mikhail-Hag", "- Gumbel-Hougard", "- Frank", "- Joe-Frank", "", "", "- Gumbel-Barnett", "", "", "", "", "", "- Genest-Ghoudi", "", "", "", "", "", "", "") Title = paste("Archimedean Copula No:", as.character(Copula), Names[Copula], "\n", RANGE, " alpha =", as.character(alpha), " tau =", as.character(Tau), " rho =", as.character(Rho)) # Plot: uv = grid2d(x = (1:(N-1))/N) D = .darchm1Copula(u = uv, alpha = alpha, type = as.character(Copula), output = "list") persp(D, theta = theta, phi = phi, col = "steelblue", shade = 0.5, ticktype = "detailed", cex = 0.5, xlab = "u", ylab = "v", zlab = "C(u,v)" ) title(main = Title) # Reset Frame: par(mfrow = c(1, 1)) } # Open Slider Menu: B = 5 C1 = "1: [-1,Inf]" C2 = "2-4-6-8-12-14-15-21: [1,Inf)" C3 = "3: [-1,1)" C4 = "5-17: (-Inf,Inf)|{0}" C5 = "7-9-10-22: (0,1]" C6 = "11: (0, 1/2]" C7 = "13-16-19-20: (0,Inf)" C8 = "18: [2, Inf)" C = c( C1, C2, C3, C4, C5, C6, C7, C8 ) L = c( -1, 1, -1, -B, 0, 0, 0, 2 ) U = c( B, B, 1, B, 1, 0.5, B, B ) A = c( 0.5, 2, 0.5, 1, 0.5, 0.2, 1, 3 ) V = rep(0.1, 8) plot.names = c("Plot - theta", "... phi") .sliderMenu(refresh.code, names = c("Copula", "N", C, plot.names), minima = c( 1, 10, L, -180, 0), maxima = c( 22, 100, U, 180, 360), resolutions = c( 1, 10, V, 1, 1), starts = c( 1, 20, A, -40, 30)) } # ------------------------------------------------------------------------------ .darchmContourSlider <- function(B = 10) { # A function implemented by Diethelm Wuertz # Description: # Displays interactively perspective plots of density #FUNCTION: # Graphic Frame: par(mfrow = c(1, 1)) # Internal Function: refresh.code = function(...) { # Sliders: Counter = c(1,2,3,2,4,2,5,2,5,5,6,2,7,2,2,7,4,8,7,7,2,5) Copula = as.integer(.sliderMenu(no = 1)) No = Counter[Copula] N = .sliderMenu(no = 2) alpha = .sliderMenu(no = No+2) n.lev = .sliderMenu(no = 11) n.col = .sliderMenu(no = 12) # Skip: if (Copula == 11) if (alpha == 0.5) return(invisible()) if (Copula == 13) if (alpha == 0) return(invisible()) # Do we have a strict Copula? strict = c( "Yes","No","Yes","Yes","Yes","Yes","No","No","Yes","Yes", "No","Yes","Yes","Yes","No","Yes","Yes","No","Yes","Yes", "No","Yes")[Copula] if (alpha < 0 & Copula == 1) strict[1] = "No" if (alpha == 0 & Copula == 16) strict[16] = "No" # What is the Range? RANGE = c( "[-1|Inf)", "[1|Inf)", "[-1|1)", "(-Inf|Inf)", "(0|1]", "(0|0.5]", "(0|Inf)", "[2|Inf)")[No] # Which one is the Limit Copula? limitTitle = rep("NA", times = 22) if (alpha == -1) limitTitle = c( "W ", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "Pi", "NA", "NA", "NA", "NA", "NA") if (alpha == 0) limitTitle = c( "Pi", "NA", "Pi", "NA", "Pi", "NA", "W ", "NA", "Pi", "Pi", "Pi", "NA", "NA", "NA", "NA", "W ", "NA", "NA", "L ", "Pi", "NA", "Pi") if (alpha == 1) limitTitle = c( "L ", "W ", "L ", "Pi", "NA", "Pi", "Pi", "W ", "NA", "NA", "NA", "L ", "Pi", "L ", "W ", "NA", "NA", "NA", "NA", "NA", "W ", "NA") limitTitle = limitTitle[Copula] if (limitTitle == "NA") { limitTitle = " " } else { limitTitle = paste(" Copula = ", limitTitle[1]) } # Tau/Rho: Tau = round(approx(.ALPHA[, Copula], .TAU[, Copula], xout = alpha)$y, digits = 3) Rho = round(approx(.ALPHA[, Copula], .RHO[, Copula], xout = alpha)$y, digits = 3) # Title: Names = c( "- Clayton", "", "- Ali-Mikhail-Hag", "- Gumbel-Hougard", "- Frank", "- Joe-Frank", "", "", "- Gumbel-Barnett", "", "", "", "", "", "- Genest-Ghoudi", "", "", "", "", "", "", "") Title = paste("Archimedean Copula No:", as.character(Copula), Names[Copula], "\n", RANGE, " alpha =", as.character(alpha), " tau =", as.character(Tau), " rho =", as.character(Rho)) # Plot: uv = grid2d(x = (1:(N-1)/N)) D = .darchm1Copula(u = uv, alpha = alpha, type = as.character(Copula), output = "list") image(D, xlim = c(0, 1), ylim = c(0,1), col = heat.colors(n.col) ) contour(D, xlab = "u", ylab = "v", nlevels = n.lev, add = TRUE) title(main = Title) # Reset Frame: par(mfrow = c(1, 1)) } # Open Slider Menu: B = 5 C1 = "1: [-1,Inf]" C2 = "2-4-6-8-12-14-15-21: [1,Inf)" C3 = "3: [-1,1)" C4 = "5-17: (-Inf,Inf)|{0}" C5 = "7-9-10-22: (0,1]" C6 = "11: (0, 1/2]" C7 = "13-16-19-20: (0,Inf)" C8 = "18: [2, Inf)" C = c( C1, C2, C3, C4, C5, C6, C7, C8 ) L = c( -1, 1, -1, -B, 0, 0, 0, 2 ) U = c( B, B, 1, B, 1, 0.5, B, B ) A = c( 0.5, 2, 0.5, 1, 0.5, 0.2, 1, 3 ) V = rep(0.1, 8) plot.names = c("Plot - levels", "... colors") .sliderMenu(refresh.code, names = c("Copula", "N", C, plot.names), minima = c( 1, 10, L, 10, 12), maxima = c( 22, 100, U, 100, 256), resolutions = c( 1, 10, V, 10, 1), starts = c( 1, 30, A, 30, 64)) } fCopulae/R/ArchimedeanModelling.R0000644000176000001440000000610012406047540016416 0ustar ripleyusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA ################################################################################ # FUNCTION: ARCHIMEDEAN COPULAE PARAMETER FITTING: # archmCopulaSim Simulates bivariate elliptical copula # archmCopulaFit Fits the paramter of an elliptical copula ################################################################################ ################################################################################ # FUNCTION: ARCHIMEDEAN COPULAE PARAMETER FITTING: # archmCopulaSim Simulates bivariate elliptical copula # archmCopulaFit Fits the paramter of an elliptical copula archmCopulaSim <- function (n, alpha = NULL, type = archmList()) { # A function implemented by Diethelm Wuertz # Description: # Simulates bivariate elliptical Copula # Match Arguments: type <- match.arg(type) Type <- as.integer(type) # Settings: if (is.null(alpha)) alpha = archmParam(type)$param # Random Variates: ans <- rarchmCopula(n = n, alpha = alpha, type = type) # Control: control = list(alpha = alpha[[1]], copula = "archm", type = type) attr(ans, "control")<-unlist(control) # Return Value: ans } # ------------------------------------------------------------------------------ archmCopulaFit <- function(u, v = NULL, type = archmList(), ...) { # A function implemented by Diethelm Wuertz # Description: # Fits the paramter of an elliptical copula # Note: # The upper limit for nu is 100 # FUNCTION: # Match Arguments: type = match.arg(type) Type = as.integer(type) # Settings: U = u V = v if (is.list(u)) { U = u[[1]] V = u[[2]] } if (is.matrix(u)) { U = u[, 1] V = u[, 2] } # Estimate Rho from Kendall's tau for all types of Copula: alpha = archmParam(type)$param # Estimate Copula: fun = function(x, type, U, V) { -mean( log(darchmCopula(u = U, v = V, alpha = x, type = type)) ) } range = archmRange(type) fit = nlminb(start = alpha, objective = fun, lower = range[1], upper = range[2], type = type, U = U, V = V, ...) # Return Value: fit } ################################################################################ fCopulae/R/ArchimedeanCopulae.R0000644000176000001440000007347512406047540016117 0ustar ripleyusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA ################################################################################ # FUNCTION: ARCHIMEDEAN COPULAE RANDOM VARIATES: # rarchmCopula Generates Archimedean copula random variates # .rNo1Copula Generates rv's for copulae No 1 # .rNo2Copula Generates rv's for copulae No 2 # FUNCTION: ARCHIMEDEAN COPULAE PROBABILITY: # parchmCopula Computes Archimedean copula probability # .parchm1Copula Utility Function # .parchm2Copula Utility Function # FUNCTION: ARCHIMEDEAN COPULAE DENSITY: # darchmCopula Computes Archimedean copula density # .darchm1Copula Utility Function # .darchm2Copula Utility Function # FUNCTION: SPECIAL BIVARIATE COPULA: # rgumbelCopula Generates fast gumbel random variates # pgumbelCopula Computes bivariate Gumbel copula probability # dgumbelCopula Computes bivariate Gumbel copula density ################################################################################ ################################################################################ rarchmCopula <- function(n, alpha = NULL, type = archmList()) { # A function implemented by Diethelm Wuertz # Description: # Generates Archimedean copula random variate # FUNCTION: # Type: type = match.arg(type) Type = as.integer(type) # Alpha: if (is.null(alpha)) alpha = archmParam(type)$param # Check alpha: check = archmCheck(alpha, type) if (Type == 1) { # Use faster Algorithm: ans = .rNo1Copula(n, alpha) } else { # Generate rv's for the remaining Copulae: X = runif(n) Y = runif(n) t = .invK(Y, alpha, type) U = .invPhi(X*.Phi(t, alpha, type), alpha, type) V = .invPhi((1-X)*.Phi(t, alpha, type), alpha, type) ans = cbind(U, V) # Add Control Attribute: colnames(ans) = NULL } # Add Control List: control = list(alpha = alpha[[1]], copula = "archm", type = type) attr(ans, "control")<-unlist(control) # Return Value: ans } # ------------------------------------------------------------------------------ .rNo1Copula <- function(n, alpha = NULL, alternative = FALSE, doplot = FALSE) { # A function implemented by Diethelm Wuertz # Description: # Generates rv's for copula No 1 # Default Parameter: if (is.null(alpha)) alpha = archmParam(1)$param # Clayton Random Variate: if (alternative) { # Source: aas04.pdf X = rgamma(n, 1/alpha) V1 = runif(n) U = (1-log(V1)/X)^(-1/alpha) V2 = runif(n) V = (1-log(V2)/X)^(-1/alpha) ans = cbind(U, V) } else { # Source: armstrong03.pdf U = runif(n) W = runif(n) # W = C(V|U) => V = ( W^(-alpha/(alpha+1)) * U^(-alpha) - U^(-alpha) + 1 )^(-1/alpha) ans = cbind(U, V) } # Optional Plot: if (doplot) { plot(U, V, cex = 0.25, main = "Copula No. 1") } # Add Attribute: colnames(ans) = NULL control = list(alpha = alpha[[1]], copula = "archm", type = "1") attr(ans, "control")<-unlist(control) # Return Value: ans } # ------------------------------------------------------------------------------ .rNo2Copula <- function(n, alpha = NULL, doplot = FALSE) { # A function implemented by Diethelm Wuertz # HERE IS SOMETHING WRONG !!!! # Description: # Generates rv's for copula No 2 # Source: armstrong03.pdf # Default Parameter: if (is.null(alpha)) alpha = archmParam(2)$param # Random Variates: U = runif(n) W = runif(n) # W = C(V|U) => V = 1 - ( (1-U)^alpha * (W^(alpha/(1-alpha)) - 1 ) + 1 ) ^ (1/alpha) ans = cbind(U, V) # Optional Plot: if (doplot) { plot(U, V, cex = 0.25, main = "Copula No. 2") } # Add Attribute: colnames(ans) = NULL control = list(alpha = alpha[[1]], copula = "archm", type = "2") attr(ans, "control")<-unlist(control) # Return Value: ans } ################################################################################ parchmCopula <- function(u = 0.5, v = u, alpha = NULL, type = archmList(), output = c("vector", "list"), alternative = FALSE ) { # A function implemented by Diethelm Wuertz # Description: # Computes extreme value copula probability # Arguments: # u, v - two numeric values or vectors of the same length at # which the copula will be computed. If 'u' is a list then the # the '$x' and '$y' elements will be used as 'u' and 'v'. # If 'u' is a two column matrix then the first column will # be used as 'u' and the the second as 'v'. # alpha - a numeric value or vector of named parameters as # required by the copula specified by the variable 'type'. # If set to NULL, then the parameters will be taken as # specified by the function 'eparchParam'. # type - the type of the Archimedean copula. An integer or character # string selected from: "1", ..., "22". # output - a character string specifying how the output should # be formatted. By default a vector of the same length as # 'u' and 'v'. If specified as "list" then 'u' and 'v' are # expected to span a two-dimensional grid as outputted by the # function 'grid2d' and the function returns a list with # elements '$x', 'y', and 'z' which can be directly used # for example by 2D plotting functions. # alternative - Should the probability be computed alternatively # in a direct way from the probability formula or by default # via the dependency function? # Value: # returns a vector or list of probabilities depending on the # value of the "output" variable. # Example: # Diagonal Value: parchmCopula((0:10)/10) # persp(parchmCopula(u = grid2d(), output = "list")) # FUNCTION: # Copula: if (alternative) { ans <- .parchm2Copula(u, v, alpha, type, output) } else { ans <- .parchm1Copula(u, v, alpha, type, output) } # Return Value: ans } # ------------------------------------------------------------------------------ .parchm1Copula <- function(u = 0.5, v = u, alpha = NULL, type = archmList(), output = c("vector", "list") ) { # A function implemented by Diethelm Wuertz # Description: # Compute Maximum Extreme Value Copulae # Arguments: # see function: parchmCopula # Example: # Diagonal Value: .parchm1Copula((0:10)/10) # persp(.parchm1Copula(u = grid2d(), output = "list")) # FUNCTION: # Match Arguments: output = match.arg(output) # Type: type = match.arg(type) Type = as.integer(type) # Settings: if (is.null(alpha)) { alpha = archmParam(type)$param } if (is.list(u)) { v = u[[2]] u = u[[1]] } if (is.matrix(u)) { v = u[,1] u = u[,2] } # Consider Special Copulae: if (alpha == 0 & Type == 1) { C.uv = pfrechetCopula(u, v, type = "pi") } else if (alpha == 1 & Type == 3) { C.uv = pfrechetCopula(u, v, type = "psp") } else if (alpha == 0 & Type == 7) { C.uv = pfrechetCopula(u, v, type = "w") } else if (alpha == 1 & Type == 7) { C.uv = pfrechetCopula(u, v, type = "pi") } else if (alpha == 0 & Type == 9) { C.uv = pfrechetCopula(u, v, type = "pi") } else if (alpha == 0 & Type == 10) { C.uv = pfrechetCopula(u, v, type = "pi") } else if (alpha == 0 & Type == 11) { C.uv = pfrechetCopula(u, v, type = "pi") } else if (alpha == 1 & Type == 13) { C.uv = pfrechetCopula(u, v, type = "pi") } else if (alpha == 0 & Type == 19) { C.uv = pfrechetCopula(u, v, type = "psp") } else if (alpha == 0 & Type == 20) { C.uv = pfrechetCopula(u, v, type = "pi") } else if (alpha == 1 & Type == 21) { C.uv = pfrechetCopula(u, v, type = "w") } else if (alpha == 0 & Type == 22) { C.uv = pfrechetCopula(u, v, type = "pi") } else { C.uv = .invPhi(.Phi(u, alpha, type) + .Phi(v, alpha, type), alpha, type) } # Require special attention for No. 20: if (type == "20") { C.uv = C.uv + (1-sign(C.uv)) * pfrechetCopula(u, v, type = "m") } # Simulate max function: C.uv = (C.uv + abs(C.uv))/2 # Correct C(u,v) on Boundary of Unit Square: C.uv[is.na(C.uv)] = 0 C.uv[which(u == 0)] = 0 C.uv[which(u == 1)] = v[which(u == 1)] C.uv[which(v == 0)] = 0 C.uv[which(v == 1)] = u[which(v == 1)] C.uv[which(u*v == 1)] = 1 C.uv[which(u+v == 0)] = 0 # Add Control Attribute: control = list(alpha = alpha[[1]], copula = "archm", type = type) attr(C.uv, "control")<-unlist(control) # As List ? if (output == "list") { N = sqrt(length(u)) x = u[1:N] y = matrix(v, ncol = N)[1, ] C.uv = list(x = x, y = y, z = matrix(C.uv, ncol = N)) } # Return Value: C.uv } # ------------------------------------------------------------------------------ .parchm2Copula <- function(u = 0.5, v = u, alpha = NULL, type = archmList(), output = c("vector", "list") ) { # A function implemented by Diethelm Wuertz # Description: # Arguments: # see function: parchmCopula # Example: # Diagonal Value: .parchm2Copula((0:10)/10) # persp(.parchm2Copula(u = grid2d(), output = "list")) # FUNCTION: # Match Arguments: output = match.arg(output) # Type: type = match.arg(type) Type = as.integer(type) # Settings: if (is.null(alpha)) { alpha = archmParam(type)$param } if (is.list(u)) { v = u[[2]] u = u[[1]] } if (is.matrix(u)) { v = u[, 1] u = u[, 2] } # Consider Special Copulae: if (alpha == 0 & Type == 1) { C.uv = pfrechetCopula(u, v, type = "pi") } else if (alpha == 1 & Type == 3) { C.uv = pfrechetCopula(u, v, type = "psp") } else if (alpha == 0 & Type == 7) { C.uv = pfrechetCopula(u, v, type = "w") } else if (alpha == 1 & Type == 7) { C.uv = pfrechetCopula(u, v, type = "pi") } else if (alpha == 0 & Type == 9) { C.uv = pfrechetCopula(u, v, type = "pi") } else if (alpha == 0 & Type == 10) { C.uv = pfrechetCopula(u, v, type = "pi") } else if (alpha == 0 & Type == 11) { C.uv = pfrechetCopula(u, v, type = "pi") } else if (alpha == 1 & Type == 13) { C.uv = pfrechetCopula(u, v, type = "pi") } else if (alpha == 0 & Type == 19) { C.uv = pfrechetCopula(u, v, type = "psp") } else if (alpha == 0 & Type == 20) { C.uv = pfrechetCopula(u, v, type = "pi") } else { if (Type == 1) {# Clayton Copula C.uv = (u^(-alpha)+v^(-alpha)-1)^(-1/alpha) } if (Type == 2) { X = 1-((1-u)^alpha+(1-v)^alpha)^(1/alpha) Y = rep(0, times = length(X)) C.uv = apply(cbind(X, Y), 1, max) } if (Type == 3) { C.uv = u*v/(1-alpha*(1-u)*(1-v)) } if (Type == 4) { # Gumbel Copula C.uv = exp( -((-log(u))^(alpha)+(-log(v))^(alpha))^(1/alpha)) } if (Type == 5) { # Frank Copula C.uv = -1/alpha*log(1+(exp(-alpha*u)-1)* (exp(-alpha*v)-1)/(exp(-alpha)-1)) } if (Type == 6) { C.uv = 1-((1-u)^alpha+(1-v)^alpha-(1-u)^alpha* (1-v)^alpha)^(1/alpha) } if (Type == 7) { X = alpha*u*v+(1-alpha)*(u+v-1) Y = rep(0, times = length(X)) C.uv = apply(cbind(X, Y), 1, max) } if (Type == 8) { X = (alpha^2*u*v-(1-u)*(1-v))/(alpha^2-(alpha-1)^2*(1-u)*(1-v)) Y = rep(0, times = length(X)) C.uv = apply(cbind(X, Y), 1, max) } if (Type == 9) { C.uv = u*v*exp(-alpha*log(u)*log(v)) } if (Type == 10) { C.uv = u*v/(1+(1-u^alpha)*(1-v^alpha))^(1/alpha) } if (Type == 11) { X = (u^alpha*v^alpha-2*(1-u^alpha)*(1-v^alpha))^(1/alpha) Y = rep(0, times = length(X)) C.uv = apply(cbind(X, Y), 1, max) } if (Type == 12) { C.uv = (1+((u^(-1)-1)^alpha+(v^(-1)-1)^alpha)^(1/alpha))^(-1) } if (Type == 13) { C.uv = exp(1-((1-log(u))^alpha+(1-log(v))^alpha-1)^(1/alpha)) } if (Type == 14) { C.uv = (1+((u^(-1/alpha)-1)^alpha + (v^(-1/alpha)-1)^alpha)^(1/alpha))^(-alpha) } if (Type == 15) { X = (1-((1-u^(1/alpha))^alpha + (1-v^(1/alpha))^alpha )^(1/alpha) )^alpha Y = rep(0, times = length(X)) C.uv = apply(cbind(X, Y), 1, max) } if (Type == 16) { C.uv = 1/2*((u+v-1-alpha*(1/u+1/v-1))+ sqrt((u+v-1-alpha*(1/u+1/v-1))^2+4*alpha)) } if (Type == 17) { C.uv = (1+((1+u)^(-alpha)-1)* ((1+v)^(-alpha)-1)/(2^(-alpha)-1))^(-1/alpha)-1 } if (Type == 18) { eps = 1/10^8 u = u - eps*(1-sign(1-u)) v = v - eps*(1-sign(1-v)) X = 1+alpha/log(exp(alpha/(u-1))+exp(alpha/(v-1))) Y = rep(0, times = length(X)) C.uv = apply(cbind(X, Y), 1, max) } if (Type == 19) { C.uv = alpha/log(exp(alpha/u)+exp(alpha/v)-exp(alpha)) } if (Type == 20) { a.range = "(0, Inf)" C.uv = (log(exp(1/u^alpha)+exp(1/v^alpha)-exp(1)))^(-1/alpha) C.uv = C.uv + (1-sign(C.uv)) * pfrechetCopula(u, v, type = "m") } if (Type == 21) { # NOT YET IMPLEMENTED warning("No. 21 alternative not active") C.uv = NA # USE: C.uv = .parchm1Copula(u = u, v = v, alpha = alpha, type = type, output = output ) return(C.uv) } if (Type == 22) { # NOT YET IMPLEMENTED warning("No. 22 alternative not active") C.uv = NA # USE: C.uv = .parchm1Copula(u = u, v = v, alpha = alpha, type = type, output = output ) return(C.uv) } } # Simulate max function: C.uv = (C.uv + abs(C.uv))/2 # Correct C(u,v) on Boundary of Unit Square: C.uv[is.na(C.uv)] = 0 C.uv[which(u == 0)] = 0 C.uv[which(u == 1)] = v[which(u == 1)] C.uv[which(v == 0)] = 0 C.uv[which(v == 1)] = u[which(v == 1)] C.uv[which(u*v == 1)] = 1 C.uv[which(u+v == 0)] = 0 # Add Control Attribute: control = list(alpha = alpha[[1]], copula = "archm", type = type) attr(C.uv, "control")<-unlist(control) # As List ? if (output == "list") { N = sqrt(length(u)) x = u[1:N] y = matrix(v, ncol = N)[1, ] C.uv = list(x = x, y = y, z = matrix(C.uv, ncol = N)) } # Return Value: C.uv } ################################################################################ darchmCopula <- function(u = 0.5, v = u, alpha = NULL, type = archmList(), output = c("vector", "list"), alternative = FALSE ) { # A function implemented by Diethelm Wuertz # Description: # Computes extreme value copula density # Arguments: # u, v - two numeric values or vectors of the same length at # which the copula will be computed. If 'u' is a list then the # the '$x' and '$y' elements will be used as 'u' and 'v'. # If 'u' is a two column matrix then the first column will # be used as 'u' and the the second as 'v'. # alpha - a numeric value or vector of named parameters as # required by the copula specified by the variable 'type'. # If set to NULL, then the parameters will be taken as # specified by the function 'archmParam'. # type - the type of the Archimedean copula. An integer or character # string selected from: "1", ..., "22". # output - a character string specifying how the output should # be formatted. By default a vector of the same length as # 'u' and 'v'. If specified as "list" then 'u' and 'v' are # expected to span a two-dimensional grid as outputted by the # function 'grid2d' and the function returns a list with # elements '$x', 'y', and 'z' which can be directly used # for example by 2D plotting functions. # alternative - Should the probability be computed alternatively # in a direct way from the probability formula or by default # via the dependency function? # Value: # returns a vector or list of probabilities depending on the # value of the "output" variable. # Example: # Diagonal Value: darchmCopula((0:10)/10) # persp(darchmCopula(u=grid2d(), output="list"), theta=-40, phi=30, xlab="x") # FUNCTION: # Copula: if (alternative) { ans = .darchm2Copula(u, v, alpha, type, output) } else { ans = .darchm1Copula(u, v, alpha, type, output) } # Return Value: ans } # ------------------------------------------------------------------------------ .darchm1Copula = function(u = 0.5, v = u, alpha = NULL, type = archmList(), output = c("vector", "list")) { # A function implemented by Diethelm Wuertz # Description: # Computes Density of Maximum Extreme Value Copulae # References: # Nelsen # Matteis, Diploma Thesis # Carmona, Evanesce # FUNCTION: # Match Arguments: output = match.arg(output) # Type: type = match.arg(type) Type = as.integer(type) # Settings: if (is.null(alpha)) { alpha = archmParam(type)$param } if (is.list(u)) { v = u[[2]] u = u[[1]] } if (is.matrix(u)) { v = u[, 1] u = u[, 2] } # Density: c.uv = .invPhiSecondDer( .Phi(u, alpha, type) + .Phi(v, alpha, type), alpha, type ) / ( .invPhiFirstDer(.Phi(u, alpha, type), alpha, type) * .invPhiFirstDer(.Phi(v, alpha, type), alpha, type) ) # c.uv[which(u*v == 0 | u*v == 1)] = 0 # Replace NAs: # c.uv[is.na(c.uv)] = 0 # Add Control Attribute: control = list(alpha = alpha[[1]], copula = "archm", type = type) attr(c.uv, "control")<-unlist(control) # As List ? if (output == "list") { N = sqrt(length(u)) x = u[1:N] y = matrix(v, ncol = N)[1, ] c.uv = list(x = x, y = y, z = matrix(c.uv, ncol = N)) } # Return Value: c.uv } # ------------------------------------------------------------------------------ .darchm2Copula <- function(u = 0.5, v = u, alpha = NULL, type = archmList(), output = c("vector", "list")) { # A function implemented by Diethelm Wuertz # Description: # Extreme Value Copulae # References: # Carmona, Evanesce # Matteis, Diploma Thesis # Notes: # "4" Gumbel(alpha->1) -> m-Copula min(u,v) # Example: # persp(z = matrix(.darchm1Copula(.gridCoord()$x, .gridCoord()$y, 1.1, "4"), 101)) # FUNCTION: # Match Arguments: output = match.arg(output) # Type: type = match.arg(type) Type = as.integer(type) # Settings: if (is.null(alpha)) { alpha = archmParam(type)$param } a = alpha if (is.list(u)) { v = u[[2]] u = u[[1]] } if (is.matrix(u)) { v = u[, 1] u = u[, 2] } # Density: if (Type == 1) { c.uv = (1 + a)*u^(-1 - a)*v^(-1 - a) * (-1 + u^(-a) + v^(-a))^(-2 - a^(-1)) } if (Type == 2) { # NOT YET IMPLEMENTED! c.uv = NA # USE: warning("No 2 alternative not available") c.uv = .darchm1Copula(u = u, v = v, alpha = alpha, type = type, output = output) return(c.uv) } if (Type == 3) { c.uv = (-1 + a^2*(-1 + u + v - u*v) - a*(-2 + u + v + u*v)) / (-1 + a*(-1 + u)*(-1 + v))^3 } if (Type == 4) { # Matteis yields wrong results! # c.uv = ((-log(u))^(-1 + a)*(-1 + a + ((-log(u))^a + # (-log(v))^a)^a^(-1))*((-log(u))^a + # (-log(v))^a)^(-2 + a^(-1))*(-log(v))^(-1 + a))/ # (exp((-log(u))^a + (-log(v))^a)^a^(-1)*u*v) # Use instead: c.uv = exp(-((-log(u))^alpha+(-log(v))^alpha)^(1/alpha)) * (- (-log(u))^alpha*(-log(v))^alpha*((-log(u))^alpha + (-log(v))^alpha)^(1/alpha)+(-log(u))^alpha*(-log(v))^alpha * ( (-log(u))^alpha+(-log(v))^alpha)^(1/alpha)*alpha + (-log(u))^(3*alpha)*(-log(v))^alpha*((-log(u))^alpha + (-log(v))^alpha)^(-2*(alpha-1)/alpha)+2*(-log(u))^(2*alpha) * (-log(v))^(2*alpha)*((-log(u))^alpha + (-log(v))^alpha)^(-2*(alpha-1)/alpha)+(-log(u))^alpha * (-log(v))^(3*alpha)*((-log(u))^alpha + (-log(v))^alpha)^(-2*(alpha-1)/alpha))/log(v)/log(u)/v/u / ( (-log(u))^(2*alpha)+2*(-log(u))^alpha*(-log(v))^alpha + (-log(v))^(2*alpha)) } if (Type == 5) { c.uv = (a*exp(a*(1 + u + v))*(-1 + exp(a)))/(exp(a) - exp(a + a*u) + exp(a*(u + v)) - exp(a + a*v))^2 } if (Type == 6) { c.uv = (1 - u)^(-1 + a)*(a - (-1 + (1 - u)^a)*(-1 + (1 - v)^a)) * ((1 - u)^a + (1 - v)^a - (1 - u)^a * (1 - v)^a)^(-2 + a^(-1)) * (1 - v)^(-1 + a) } if (Type == 7) { # NOT YET IMPLEMENTED! c.uv = NA # USE: warning("No 7 alternative not available") c.uv = .darchm1Copula(u = u, v = v, alpha = alpha, type = type, output = output) return(c.uv) } if (Type == 8) { # NOT YET IMPLEMENTED! c.uv = NA # USE: warning("No 8 alternative not available") c.uv = .darchm1Copula(u = u, v = v, alpha = alpha, type = type, output = output) return(c.uv) } if (Type == 9) { c.uv = (1 - a - a*log(v) + a*log(u)*(-1 + a*log(v))) / exp(a*log(u)*log(v)) } if (Type == 10) { c.uv = (2 - v^a + u^a*(-1 + v^a))^(-2 - a^(-1)) * (4 - 2*v^a + u^a*(-2 - (-1 + a)*v^a)) } if (Type == 11) { # NOT YET IMPLEMENTED! c.uv = NA # USE: warning("No 11 alternative not available") c.uv = .darchm1Copula(u = u, v = v, alpha = alpha, type = type, output = output) return(c.uv) } if (Type == 12) { c.uv = ((-1+u^(-1))^a*(-1+a+((-1+u^(-1))^a + (-1+v^(-1))^a)^a^(-1)+a*((-1+u^(-1))^a + (-1+v^(-1))^a)^a^(-1))*((-1+u^(-1))^a + (-1+v^(-1))^a)^(-2+a^(-1))*(-1+v^(-1))^a)/ ((-1+u)*u*(1+((-1+u^(-1))^a + (-1+v^(-1))^a)^a^(-1))^3*(-1+v)*v) } if (Type == 13) { c.uv = (exp(1 - (-1 + (1 - log(u))^a + (1 - log(v))^a)^a^(-1)) * (1 - log(u))^(-1 + a)*(-1 + a + (-1 + (1 - log(u))^a + (1 - log(v))^a)^a^(-1))*(-1 + (1 - log(u))^a + (1 - log(v))^a)^(-2 + a^(-1)) * (1 - log(v))^(-1 + a))/(u*v) } if (Type == 14) { c.uv = ((-1+u^(-a^(-1)))^a*(-1+v^(-a^(-1)))^a * ((-1+u^(-a^(-1)))^a + (-1+v^(-a^(-1)))^a)^(-2+a^(-1)) * (1+((-1+u^(-a^(-1)))^a + (-1+v^(-a^(-1)))^a)^a^(-1))^(-2-a) * (-1+a+2*a*((-1+u^(-a^(-1)))^a + (-1+v^(-a^(-1)))^a)^a^(-1))) / (a*u*(-1+u^a^(-1))*v*(-1+v^a^(-1))) } if (Type == 15) { # NOT YET IMPLEMENTED! c.uv = NA # USE: warning("No 15 alternative not available") c.uv = .darchm1Copula(u = u, v = v, alpha = alpha, type = type, output = output) return(c.uv) } if (Type == 16) { c.uv = (2*a*(a^2 + u^2*v^2 + a*(u^2 + v^2))) / (sqrt(4*a + (-1 + u - a*(-1 + u^(-1) + v^(-1)) + v)^2) * (u^2*v^2*(-1 + u + v)^2 + a^2*(u + v - u*v)^2 + 2*a*u*v*(u^2*(-1 + v) - (-1 + v)*v + u*(1 - v + v^2)))) } if (Type == 17) { c.uv = (2^a*((-1 + 2^a)*a*(1 + u)^a*(1 + v)^a + 2^a*(-1 + (1 + u)^a) * (-1 + (1 + v)^a)))/((1 + u)*(1 + v)*(2^a - 2^a*(1 + u)^a - 2^a*(1 + v)^a + (1 + u)^a*(1 + v)^a)^2 * (1 + ((-1 + (1 + u)^(-a)) * (-1 + (1 + v)^(-a))) / (-1 + 2^(-a)))^a^(-1)) } if (Type == 18) { # NOT YET IMPLEMENTED! c.uv = NA # USE: warning("No 18 alternative not available") c.uv = .darchm1Copula(u = u, v = v, alpha = alpha, type = type, output = output) return(c.uv) } if (Type == 19) { c.uv = (a^3*exp(a*(u^(-1) + v^(-1)))*(2 + log(-exp(a) + exp(a/u) + exp(a/v))))/((-exp(a) + exp(a/u) + exp(a/v))^2*u^2*v^2*log(-exp(a) + exp(a/u) + exp(a/v))^3) } if (Type == 20) { c.uv = (exp(u^(-a) + v^(-a))*u^(-1 - a)*v^(-1 - a) * log(-exp(1) + exp(u^(-a)) + exp(v^(-a)))^(-2 - a^(-1)) * (1 + a + a*log(-exp(1) + exp(u^(-a)) + exp(v^(-a))))) / (-exp(1) + exp(u^(-a)) + exp(v^(-a)))^2 } if (Type == 21) { # NOT YET IMPLEMENTED! c.uv = NA # USE: warning("No 21 alternative not available") c.uv = .darchm1Copula(u = u, v = v, alpha = alpha, type = type, output = output) return(c.uv) } if (Type == 22) { # NOT YET IMPLEMENTED! c.uv = NA # USE: warning("No 22 alternative not available") c.uv = .darchm1Copula(u = u, v = v, alpha = alpha, type = type, output = output) return(c.uv) } # Replace NAs: # c.uv[is.na(c.uv)] = 0 # Add Control Attribute: control = list(alpha = alpha[[1]], copula = "archm", type = type) attr(c.uv, "control")<-unlist(control) # As List ? if (output == "list") { N = sqrt(length(u)) x = u[1:N] y = matrix(v, ncol = N)[1, ] c.uv = list(x = x, y = y, z = matrix(c.uv, ncol = N)) } # Return Value: c.uv } ################################################################################ rgumbelCopula <- function(n = 100, alpha = 2) { # A function implemented by Diethelm Wuertz # Description: # Generates fast gumbel random variates # FUNCTION: # Stable RVs: dim = 2 theta <- runif(n, 0, pi) w <- rexp(n) b = 1/alpha a <- sin((1-b)*theta)*(sin(b*theta))^(b/(1-b)) / (sin(theta))^(1/(1-b)) fr = (a/w)^((1-b)/b) fr <- matrix(fr, nrow = n, ncol = dim) val <- matrix(runif(dim * n), nrow = n) s = -log(val)/fr # Bivariate Gumbel RVs: ans = exp(-s^(1/alpha) ) # Return Value: ans } # ------------------------------------------------------------------------------ pgumbelCopula <- function(u = 0.5, v = u, alpha = 2, output = c("vector", "list")) { # A function implemented by Diethelm Wuertz # Description: # Computes bivariate Gumbel copula probability # FUNCTION: # Bivariate Gumbel Probability: ans = parchmCopula (u, v, alpha, type = "4", output = output, alternative = FALSE) # Return Value: ans } # ------------------------------------------------------------------------------ dgumbelCopula <- function(u = 0.5, v = u, alpha = 2, output = c("vector", "list")) { # A function implemented by Diethelm Wuertz # Description: # Computes bivariate Gumbel copula density # FUNCTION: # Bivariate Gumbel Density: ans <- darchmCopula (u, v, alpha, type = "4", output = output, alternative = FALSE) # Return Value: ans } fCopulae/R/EllipticalCopulae.R0000644000176000001440000012533112406047540015766 0ustar ripleyusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA ################################################################################ # FUNCTION: ELLIPTICAL COPULAE RANDOM DEVIATES: # rellipticalCopula Generates elliptical copula variates # rellipticalSlider Generates interactive plots of random variates # .rnormCopula Generates normal copula random variate # .rcauchyCopula Generates Cauchy copula random variate # .rtCopula Generates Student-t copula random variate # FUNCTION: ELLIPTICAL COPULAE PROBABILITY: # pellipticalCopula Computes elliptical copula probability # pellipticalSlider Generates interactive plots of probability # .pnormCopula Computes normal copula probability # .pcauchyCopula Computes Cauchy copula probability # .ptCopula Computes Student-t copula probability # .pellipticalCopulaGrid Fast equidistant grid version # .pellipticalCopulaDiag Fast diagonal cross section version # .pellipticalPerspSlider Interactive perspective plots of probability # .pellipticalContourSlider Interactive contour plots of probability # FUNCTION: ELLIPTICAL COPULAE DENSITY: # dellipticalCopula Computes elliptical copula density # dellipticalSlider Generates interactive plots of density # .dnormCopula Computes normal copula density # .dcauchyCopula Computes Cauchy copula density # .dtCopula Computes Student-t copula density # .dellipticalCopulaGrid Fast grid version for elliptical copula density # .dellipticalPerspSlider Interactive perspective plots of density # .dellipticalContourSlider Interactive contour plots of density ################################################################################ ################################################################################ # FUNCTION: ELLIPTICAL COPULAE RANDOM DEVIATES: # rellipticalCopula Generates elliptical copula variates # rellipticalSlider Generates interactive plots of random variates # .rnormCopula Generates normal copula random variate # .rcauchyCopula Generates Cauchy copula random variate # .rtCopula Generates Student-t copula random variate rellipticalCopula <- function(n, rho = 0.75, param = NULL, type = c("norm", "cauchy", "t")) { # A function implemented by Diethelm Wuertz # Description: # Computes extreme value copula probability # Arguments: # n - number of deviates to be generated. # rho - a numeric value setting the coorelation strength, ranging # between minus one and one. # nu - the number of degrees of freedom, only required for # Student-t copulae. # type - the type of the elliptical copula. Either "norm" or # "t" denoting the normal or Student-t copula, respectively. # output - a character string specifying how the output should # be formatted. By default a vector of the same length as # 'u' and 'v'. If specified as "list" then 'u' and 'v' are # expected to span a two-dimensional grid as outputted by the # function 'grid2d' and the function returns a list with # elements '$x', 'y', and 'z' which can be directly used # for example by 2D plotting functions. # Value: # returns a vector or list of probabilities depending on the # value of the "output" variable. # Example: # Diagonal Value: pnormCopula((0:10)/10) # persp(pnormCopula(u = grid2d(), output = "list")) # FUNCTION: # Settings: type = match.arg(type) # Parameters: if (type == "t") { if(is.null(param)) { param = c(nu = 4) } else { param = c(nu = param) } names(param) = "nu" } # Copula: if (type == "norm") ans = .rnormCopula(n = n, rho = rho) if (type == "cauchy") ans = .rcauchyCopula(n = n, rho = rho) if (type == "t") ans = .rtCopula(n = n, rho = rho, nu = param) # Add Control Attribute: control = list(rho = rho, param = param, type = type) attr(ans, "control")<-unlist(control) # Return Value: ans } # ------------------------------------------------------------------------------ rellipticalSlider <- function(B = 100) { # A function implemented by Diethelm Wuertz # Description: # Displays interactively perspective plots of random variates #FUNCTION: # Graphic Frame: par(mfrow = c(1, 1)) # Internal Function: refresh.code <- function(...) { # Startup Counter: .counter <- getRmetricsOptions(".counter") + 1 setRmetricsOptions(.counter = .counter) if (.counter < 7) return () # Sliders: Copula = .sliderMenu(no = 1) N = .sliderMenu(no = 2) rho = .sliderMenu(no = 3) nu = .sliderMenu(no = 4) seed = .sliderMenu(no = 5) size = .sliderMenu(no = 6) col = .sliderMenu(no = 7) Names = c("- Normal", "- Cauchy", "- Student t") Type = c("norm", "cauchy", "t") eps = 1.0e-6 if (rho == +1) rho = rho - eps if (rho == -1) rho = rho + eps # Tau and Rho: Tau = ellipticalTau(rho) Rho = ellipticalRho(rho) # Plot: Title = paste("Elliptical Copula No:", as.character(Copula), Names[Copula], "\nrho =", as.character(rho), "|") if (Copula == 2) Title = paste(Title, "nu =", as.character(nu), "|") Title = paste(Title, "Kendall = ", as.character(round(Tau, digits = 3)), "|", "Spearman = ", as.character(round(Rho, digits = 3)) ) set.seed(seed) R = rellipticalCopula(n = N, rho = rho, param = nu, type = Type[Copula]) plot(x = R[, 1], y = R[, 2], xlim = c(0, 1), ylim = c(0, 1), xlab = "u", ylab = "v", pch = 19, col = col, cex = size) title(main = Title) # Reset Frame: par(mfrow = c(1, 1)) } # Open Slider Menu: setRmetricsOptions(.counter = 0) plot.names = c("Plot - size", "... color") .sliderMenu(refresh.code, names = c("Copula", "N", "rho", "t: nu", "seed", plot.names), minima = c( 1, 1000, -1, 1, 1000, 0, 1), maxima = c( 3, 10000, +1, B, 9999, 1, 16), resolutions = c( 1, 500, 0.01, 1, 1, 0.1, 1), starts = c( 1, 1000, 0, 4, 4711, 0.5, 1)) } # ------------------------------------------------------------------------------ .rnormCopula <- function(n, rho = 0.75) { # A function implemented by Diethelm Wuertz # Description: # Generates normal copula random variate # Example: # UV = rnormCopula(n = 10000); plot(UV[,1], UV[,2], cex = 0.25) # FUNCTION: # Use: X = .rnorm2d(n, rho) or alternatively: X = fMultivar:::.rnorm2d(n = n, rho = rho) # Generate Z <- NULL for(i in (1:n)) Z <- rbind(Z, pnorm(X [i,])) # Return Value: Z } # ------------------------------------------------------------------------------ .rcauchyCopula <- function(n, rho = 0.75) { # A function implemented by Diethelm Wuertz # Description: # Generates Student-t copula random variate # Example: # UV = rtCopula(n = 10000); plot(UV[,1], UV[,2], cex = 0.25) # FUNCTION: # Cauchy Deviates: Z = .rtCopula(n = n, rho = rho, nu = 1) # Return Value: Z } # ------------------------------------------------------------------------------ .rtCopula <- function(n, rho = 0.75, nu = 4) { # A function implemented by Diethelm Wuertz # Description: # Generates Student-t copula random variate # Example: # UV = rtCopula(n = 10000); plot(UV[,1], UV[,2], cex = 0.25) # FUNCTION: # Use: X = .rnorm2d(n, rho) or alternatively: X = rt2d(n = n, rho = rho, nu = nu) # Generate Z = NULL for (i in (1:n)) Z = rbind(Z, pt(X [i,], df = nu)) # Return Value: Z } ################################################################################ # FUNCTION: ELLIPTICAL COPULAE PROBABILITY: # pellipticalCopula Computes elliptical copula probability # pellipticalSlider Generates interactive plots of probability # .pnormCopula Computes normal copula probability # .pcauchyCopula Computes Cauchy copula probability # .ptCopula Computes Student-t copula probability # .pellipticalCopulaGrid Fast equidistant grid version # .pellipticalCopulaDiag Fast diagonal cross section version # .pellipticalPerspSlider Interactive perspective plots of probability # .pellipticalContourSlider Interactive contour plots of probability pellipticalCopula <- function(u = 0.5, v = u, rho = 0.75, param = NULL, type = ellipticalList(), output = c("vector", "list"), border = TRUE) { # A function implemented by Diethelm Wuertz # Description: # Computes extreme value copula probability # Arguments: # u, v - two numeric values or vectors of the same length at # which the copula will be computed. If 'u' is a list then the # the '$x' and '$y' elements will be used as 'u' and 'v'. # If 'u' is a two column matrix then the first column will # be used as 'u' and the the second as 'v'. # rho - a numeric value setting the coorelation strength, ranging # between minus one and one. # param - distributional parameters, the number of degrees of # freedom for the Student-t copulae. # type - the type of the elliptical copula. Either "norm" or # "t" denoting the normal or Student-t copula, respectively. # output - a character string specifying how the output should # be formatted. By default a vector of the same length as # 'u' and 'v'. If specified as "list" then 'u' and 'v' are # expected to span a two-dimensional grid as outputted by the # function 'grid2d' and the function returns a list with # elements '$x', 'y', and 'z' which can be directly used # for example by 2D plotting functions. # Value: # returns a vector or list of probabilities depending on the # value of the "output" variable. # FUNCTION: # Match Arguments: type <- match.arg(type) output <- match.arg(output) # Settings: subdivisions = 100 if (is.list(u)) { v = u[[2]] u = u[[1]] } if (is.matrix(u)) { v = u[, 2] u = u[, 1] } if (length(u) == 1 & u[1] > 1) { return(.pellipticalCopulaGrid(N = u, rho, param, type, border = border)) } # Parameters: if (type == "t") if (is.null(param)) param = c(nu = 4) if (type == "kotz") if (is.null(param)) param = c(r = 1) if (type == "epower") if (is.null(param)) param = c(r = 1, s = 1) # Specical Copulae: if (type == "norm") { if (rho == -1) { ans <- pfrechetCopula(u = u, v = v, type = "m", output = output) return(ans) } else if (rho == +1) { ans <- pfrechetCopula(u = u, v = v, type = "w", output = output) return(ans) } else { ans = .pnormCopula(u = u, v = v, rho = rho, output = output) return(ans) } } else if (type == "cauchy") { ans <- .pcauchyCopula(u = u, v = v, rho = rho, output = output) return(ans) } else if (type == "t") { if (is.null(param)) param = 4 ans <- .ptCopula(u = u, v = v, rho = rho, nu = param, output = output) return(ans) } # The remaining Copulae - Compute Density on Regular Grid: N = subdivisions x = (0:N)/N c.uv = .dellipticalCopulaGrid(N = N, rho, param, type, border = TRUE) c.uv$z[is.na(c.uv$z)] = 0 # Integrate to get Probability: C.uv = 0*c.uv$z for (i in 1:(N+1)) { D = matrix(rep(0, times = (N+1)^2), ncol = N+1) for (j in 1:i) { D[1:i, j] = 1 C.uv[i,j] = C.uv[j,i] = sum(D*c.uv$z) } } C.uv = C.uv/N^2 # Take care about the Boundary on the Unit Square: C.uv[1, ] = C.uv[, 1] = 0 C.uv[N+1, ] = C.uv[, N+1] = c.uv$x # Interpolate for the desired Values on the grid: U0 = trunc(u*N) V0 = trunc(v*N) P = (u - U0/N) Q = (v - V0/N) U0 = U0 + 1 U1 = U0 + 1 V0 = V0 + 1 V1 = V0 + 1 C.vec = rep(NA, times = length(u)) for ( i in 1:length(u) ) { p = P[i] q = Q[i] if (p == 0 & q == 0) { C.vec[i] = C.uv[U0[i], V0[i]] } else if (p == 0 & q > 0) { C.vec[i] = (1-q)*C.uv[U0[i], V0[i]] + q*C.uv[U0[i], V1[i]] } else if (p > 0 & q == 0) { C.vec[i] = (1-p)*C.uv[U0[i], V0[i]] + p*C.uv[U1[i], V0[i]] } else { C.vec[i] = (1-p)*(1-q)*C.uv[U0[i], V0[i]] + p*(1-q)*C.uv[U1[i], V0[i]] + (1-p)*q*C.uv[U0[i], V1[i]] + p*q*C.uv[U1[i], V1[i]] } } C.uv = round(C.vec, digits = 3) attr(C.uv, "control") <- c(rho = rho) # As List ? if (output == "list") { N = sqrt(length(u)) x = u[1:N] y = matrix(v, ncol = N)[1, ] names(x) = names(y) = NULL C.uv = list(x = x, y = y, z = matrix(C.uv, ncol = N)) } # Return Value: C.uv } # ------------------------------------------------------------------------------ pellipticalSlider <- function(type = c("persp", "contour"), B = 20) { # A function implemented by Diethelm Wuertz # Description: # Displays interactively plots of probability # Description: # Displays interactively plots of probability # Arguments: # type - a character string specifying the plot type. # Either a perspective plot which is the default or # a contour plot with an underlying image plot will # be created. # B - the maximum slider menu value when the boundary # value is infinite. By default this is set to 10. # FUNCTION: # Settings: type = match.arg(type) # Plot: if (type == "persp") .pellipticalPerspSlider(B = B) if (type == "contour") .pellipticalContourSlider(B = B) # Return Value: invisible() } # ------------------------------------------------------------------------------ .pnormCopula <- function(u = 0.5, v = u, rho = 0.75, output = c("vector", "list") ) { # A function implemented by Diethelm Wuertz # Description: # Computes normal copula probability # Arguments: # see function 'pellipticalCopula' # FUNCTION: # Type: output = match.arg(output) # Settings: type = "norm" if (is.list(u)) { v = u[[2]] u = u[[1]] } if (is.matrix(u)) { v = u[, 2] u = u[, 1] } # Copula Probability: C.uv = pnorm2d(qnorm(u), qnorm(v), rho = rho) names(C.uv) = NULL # Simulates Max function: C.uv = (C.uv + abs(C.uv))/2 # On Boundary: C.uv[is.na(C.uv)] = 0 C.uv[which(u == 0)] = 0 C.uv[which(u == 1)] = v[which(u == 1)] C.uv[which(v == 0)] = 0 C.uv[which(v == 1)] = u[which(v == 1)] C.uv[which(u*v == 1)] = 1 C.uv[which(u+v == 0)] = 0 # Result: attr(C.uv, "control") <- c(rho = rho) # As List ? if (output == "list") { N = sqrt(length(u)) x = u[1:N] y = matrix(v, ncol = N)[1, ] C.uv = list(x = x, y = y, z = matrix(C.uv, ncol = N)) } # Return Value: C.uv } # ------------------------------------------------------------------------------ .pcauchyCopula <- function(u = 0.5, v = u, rho = 0.75, output = c("vector", "list") ) { # A function implemented by Diethelm Wuertz # Description: # Computes Student-t copula probability # Arguments: # see function 'pellipticalCopula' # FUNCTION: # Cauchy Probability: C.uv <- .ptCopula(u = u, v = v, rho = rho, nu = 1, output = output) attr(C.uv, "control") <- c(rho = rho) # Return Value: C.uv } # ------------------------------------------------------------------------------ .ptCopula <- function(u = 0.5, v = u, rho = 0.75, nu = 4, output = c("vector", "list") ) { # A function implemented by Diethelm Wuertz # Description: # Computes Student-t copula probability # Arguments: # see function 'pellipticalCopula' # FUNCTION: # Match Arguments: output <- match.arg(output) # Settings: type = "t" if (is.list(u)) { v = u[[2]] u = u[[1]] } if (is.matrix(u)) { v = u[, 2] u = u[, 1] } # Copula Probability: C.uv <- pt2d(qt(u, df = nu), qt(v, df = nu), rho = rho, nu = nu) names(C.uv) = NULL # Simulates Max function: C.uv = (C.uv + abs(C.uv))/2 # On Boundary: C.uv[is.na(C.uv)] = 0 C.uv[which(u == 0)] = 0 C.uv[which(u == 1)] = v[which(u == 1)] C.uv[which(v == 0)] = 0 C.uv[which(v == 1)] = u[which(v == 1)] C.uv[which(u*v == 1)] = 1 C.uv[which(u+v == 0)] = 0 # Result: attr(C.uv, "control") <- c(rho = rho, nu = nu) # As List ? if (output == "list") { N = sqrt(length(u)) x = u[1:N] y = matrix(v, ncol = N)[1, ] C.uv = list(x = x, y = y, z = matrix(C.uv, ncol = N)) } # Return Value: C.uv } # ------------------------------------------------------------------------------ .pellipticalCopulaGrid <- function(N, rho = 0.75, param = NULL, type = ellipticalList(), border = TRUE) { # A function implemented by Diethelm Wuertz # Description: # Computes elliptical copula probability on a 2d grid # Arguments: # see function pellipticalCopula() # FUNCTION: # Settings: U = (0:N)/N V = (1:(N-1))/N # Compute Density on Regular Grid: c.uv = .dellipticalCopulaGrid(N, rho, param, type, border = TRUE) c.uv$z[is.na(c.uv$z)] = 0 # Integrate to get Probability: if (TRUE) { C.uv = 0*c.uv$z for (i in 1:(N+1)) { for (j in 1:i) { C.uv[i,j] = C.uv[j,i] = sum(c.uv$z[1:i, 1:j]) } } C.uv = C.uv/N^2 } if (FALSE) { # This is much slower ! IJ = grid2d(1:(N+1)) X = cbind(IJ$x, IJ$y) fun = function(X, C) sum(C[1:X[1], 1:X[2]]) C.uv = apply(X, MARGIN=1, FUN = fun, C = c.uv$z) C.uv = matrix(C.uv, byrow = TRUE, ncol = N+1) / N^2 } # Probability - Take care about the Boundary on the Unit Square: C.uv[1, ] = C.uv[, 1] = 0 C.uv[N+1, ] = C.uv[, N+1] = c.uv$x names(C.uv) = NULL attr(C.uv, "control") <- c(rho = rho) C.uv = list(x = U, y = U, z = matrix(C.uv, ncol = length(U))) if (!border) { C.uv$z = C.uv$z[-1, ] C.uv$z = C.uv$z[-N, ] C.uv$z = C.uv$z[, -1] C.uv$z = C.uv$z[, -N] C.uv$x = C.uv$y = V } # Return Value: C.uv } # ------------------------------------------------------------------------------ .pellipticalCopulaDiag <- function(N, rho = 0.75, param = NULL, type = ellipticalList(), border = TRUE) { # A function implemented by Diethelm Wuertz # Description: # Computes elliptical diagonal cross section copula probability # Arguments: # see function pellipticalCopula() # FUNCTION: # Settings: U = (0:N)/N V = (1:(N-1))/N # Compute Density on Regular Grid: c.uv = .dellipticalCopulaGrid(N, rho, param, type[1], border = TRUE) c.uv$z[is.na(c.uv$z)] = 0 # Integrate to get Probability: C.uu = 0*U for (i in 1:(N+1)) { C.uu[i] = sum(c.uv$z[1:i, 1:i]) } C.uu = C.uu/N^2 names(C.uu) = NULL attr(C.uu, "control") <- c(rho = rho) if (border) { C.uu = list(x = U, y = C.uu) } else { C.uu = list(x = V, y = C.uu[c(-1,-(N+1))]) } # Return Value: C.uu } # ------------------------------------------------------------------------------ .pellipticalPerspSlider <- function(B = 20) { # A function implemented by Diethelm Wuertz # Description: # Displays interactively perspective plots of probability # Arguments: # FUNCTION: # Graphic Frame: par(mfrow = c(1, 1)) # Internal Function: refresh.code = function(...) { # Startup Counter: .counter <- getRmetricsOptions(".counter") + 1 setRmetricsOptions(.counter = .counter) if (.counter < 7) return () # Sliders: Copula = .sliderMenu(no = 1) N = .sliderMenu(no = 2) rho = .sliderMenu(no = 3) nu = .sliderMenu(no = 4) s = .sliderMenu(no = 5) theta = .sliderMenu(no = 6) phi = .sliderMenu(no = 7) r = 1 # Title: Names = c("- Normal", "- Student t", "- Logistic", "- Exponential Power") if (nu == 1) Names[2] = "- Student-t [Cauchy]" if (s == 0.5) Names[4] = "- Exponential Power [Laplace]" if (s == 1) Names[4] = "- Exponential Power [Kotz|Normal]" Title = paste("Elliptical Copula No:", as.character(Copula), Names[Copula], "\nrho = ", as.character(rho)) if (Copula == 2) Title = paste(Title, "nu =", as.character(nu)) if (Copula == 4) Title = paste(Title, "s =", as.character(s)) # Plot: Type = c("norm", "t", "logistic", "epower") param = NULL if (Copula == 2) param = nu if (Copula == 4) param = c(r, s) P = .pellipticalCopulaGrid(N = N, rho = rho, param = param, type = Type[Copula], border = TRUE) persp(P, theta = theta, phi = phi, col = "steelblue", shade = 0.5, ticktype = "detailed", cex = 0.5, xlab = "u", ylab = "v", zlab = "C(u, v)", xlim = c(0, 1), ylim = c(0, 1), zlim = c(0, 1) ) title(main = Title) Tau = as.character(round(2*asin(rho)/pi, 2)) mTitle = paste("Tau", Tau) mtext(mTitle, side = 4, col = "grey", cex = 0.7) mTitle = paste("1: Normal | 2: Student-t [Cauchy] | 3: Logistic |", "4: Exponential Power [Laplace|Kotz]") mtext(mTitle, side = 1, line = 3, col = "grey", cex = 0.7) # Reset Frame: par(mfrow = c(1, 1)) } # Open Slider Menu: setRmetricsOptions(.counter = 0) plot.names = c("Plot - theta", "... phi") .sliderMenu(refresh.code, names = c("Copula", "N", "rho", "2: nu", "4: s", plot.names), minima = c( 1, 10, -0.95, 1, 0.1, -180, 0), maxima = c( 4, 100, 0.95, B, 5, 180, 360), resolutions = c( 1, 10, 0.05, 0.1, 0.1, 1, 1), starts = c( 1, 20, 0.50, 4, 1, -40, 30)) } # ------------------------------------------------------------------------------ .pellipticalContourSlider <- function(B = 20) { # A function implemented by Diethelm Wuertz # Description: # Displays interactively perspective plots of probability # Arguments: # FUNCTION: # Graphic Frame: par(mfrow = c(1, 1)) # Internal Function: refresh.code = function(...) { # Startup Counter: .counter <- getRmetricsOptions(".counter") + 1 setRmetricsOptions(.counter = .counter) if (.counter < 7) return () # Sliders: Copula = .sliderMenu(no = 1) N = .sliderMenu(no = 2) rho = .sliderMenu(no = 3) nu = .sliderMenu(no = 4) s = .sliderMenu(no = 5) nlev = .sliderMenu(no = 6) ncol = .sliderMenu(no = 7) r = 1 # Title: Names = c("- Normal", "- Student t", "- Logistic", "- Exponential Power") if (nu == 1) Names[2] = "- Student-t [Cauchy]" if (s == 0.5) Names[4] = "- Exponential Power [Laplace]" if (s == 1) Names[4] = "- Exponential Power [Kotz|Normal]" Title = paste("Elliptical Copula No:", as.character(Copula), Names[Copula], "\nrho = ", as.character(rho)) if (Copula == 2) Title = paste(Title, "nu =", as.character(nu)) if (Copula == 4) Title = paste(Title, "s =", as.character(s)) # Plot: Type = c("norm", "t", "logistic", "epower") param = NULL if (Copula == 2) param = nu if (Copula == 4) param = c(r, s) P = .pellipticalCopulaGrid(N = N, rho = rho, param = param, type = Type[Copula], border = FALSE) image(P, col = heat.colors(ncol), ylab = "v") mtext("u", side = 1, line = 2, cex = 0.7) contour(P, nlevels = nlev, add = TRUE) title(main = Title) Tau = as.character(round(2*asin(rho)/pi, 2)) mTitle = paste("Tau", Tau) mtext(mTitle, side = 4, col = "grey", cex = 0.7) mTitle = paste("1: Normal | 2: Student-t [Cauchy] | 3: Logistic |", "4: Exponential Power [Laplace|Kotz]") mtext(mTitle, side = 1, line = 3, col = "grey", cex = 0.7) # Reset Frame: par(mfrow = c(1, 1)) } # Open Slider Menu: setRmetricsOptions(.counter = 0) plot.names = c("Plot - levels", "... colors") .sliderMenu(refresh.code, names = c("Copula", "N", "rho", "2: nu", "4: s", plot.names), minima = c( 1, 10, -0.95, 1, 0.1, 5, 12), maxima = c( 4, 100, 0.95, B, 5, 100, 256), resolutions = c( 1, 10, 0.05, 0.1, 0.1, 5, 4), starts = c( 1, 20, 0.50, 4, 1, 10, 32)) } ################################################################################ # FUNCTION: ELLIPTICAL COPULAE DENSITY: # dellipticalCopula Computes elliptical copula density # dellipticalSlider Generates interactive plots of density # .dnormCopula Computes normal copula density # .dcauchyCopula Computes Cauchy copula density # .dtCopula Computes Student-t copula density # .dellipticalCopulaGrid Fast grid version for elliptical copula density # .dellipticalPerspSlider Interactive perspective plots of density # .dellipticalContourSlider Interactive contour plots of density dellipticalCopula <- function(u = 0.5, v = u, rho = 0.75, param = NULL, type = ellipticalList(), output = c("vector", "list"), border = TRUE) { # A function implemented by Diethelm Wuertz # Description: # Computes extreme value copula density # Arguments: # u, v - two numeric values or vectors of the same length at # which the copula will be computed. If 'u' is a list then the # the '$x' and '$y' elements will be used as 'u' and 'v'. # If 'u' is a two column matrix then the first column will # be used as 'u' and the the second as 'v'. # rho - a numeric value setting the coorelation strength, ranging # between minus one and one. # param - additional distributional parameters. # type - the type of the elliptical copula. Either "norm" or # "t" denoting the normal or Student-t copula, respectively. # output - a character string specifying how the output should # be formatted. By default a vector of the same length as # 'u' and 'v'. If specified as "list" then 'u' and 'v' are # expected to span a two-dimensional grid as outputted by the # function 'grid2d' and the function returns a list with # elements '$x', 'y', and 'z' which can be directly used # for example by 2D plotting functions. # Value: # returns a vector or list of probabilities depending on the # value of the "output" variable. # Example: # Diagonal Value: pnormCopula((0:10)/10) # persp(pnormCopula(u = grid2d(), output = "list")) # FUNCTION: # Use Grid Version? if (is.numeric(u)) { if (length(u) == 1 & u[1] > 1) { ans = .dellipticalCopulaGrid(N = u, rho = rho, param = param, type = type, border = border) return(ans) } } # Match Arguments: type = match.arg(type) output = match.arg(output) # Settings: if (is.list(u)) { v = u[[2]] u = u[[1]] } if (is.matrix(u)) { v = u[, 2] u = u[, 1] } if (length(u) == 1 & u[1] > 1) { return(.pellipticalCopulaGrid(N = u, rho, param, type, border = border)) } # Parameters: if (type == "t") if (is.null(param)) param = c(nu = 4) if (type == "kotz") if (is.null(param)) param = c(r = 1) if (type == "epower") if (is.null(param)) param = c(r = 1, s = 1) # Density: x = .qelliptical(u, param = param, type = type) y = .qelliptical(v, param = param, type = type) c.uv = delliptical2d(x, y, rho = rho, param = param, type = type) / ( .delliptical(x, param = param, type = type) * .delliptical(y, param = param, type = type) ) if (rho == 0 & type == "norm") c.uv[!is.na(c.uv)] = 1 names(c.uv) = NULL attr(c.uv, "control") <- c(rho = rho) if (output == "list") { N = sqrt(length(u)) x = u[1:N] y = matrix(v, ncol = N)[1, ] c.uv = list(x = x, y = y, z = matrix(c.uv, ncol = N)) } # Return Value: c.uv } # ------------------------------------------------------------------------------ dellipticalSlider <- function(type = c("persp", "contour"), B = 20) { # A function implemented by Diethelm Wuertz # Description: # Displays interactively plots of density # Description: # Displays interactively plots of density # Arguments: # type - a character string specifying the plot type. # Either a perspective plot which is the default or # a contour plot with an underlying image plot will # be created. # B - the maximum slider menu value when the boundary # value is infinite. By default this is set to 10. # FUNCTION: # Settings: type = match.arg(type) # Plot: if (type == "persp") .dellipticalPerspSlider(B = B) if (type == "contour") .dellipticalContourSlider(B = B) # Return Value: invisible() } # ------------------------------------------------------------------------------ .dnormCopula <- function(u = 0.5, v = u, rho = 0.75, output = c("vector", "list") ) { # A function implemented by Diethelm Wuertz # Description: # Computes normal copula density # Arguments: # see function 'dellipticalCopula' # FUNCTION: # Type: output = match.arg(output) # Settings: type = "norm" if (is.list(u)) { v = u[[2]] u = u[[1]] } if (is.matrix(u)) { v = u[, 2] u = u[, 1] } # Copula Density: x = qnorm(u) y = qnorm(v) c.uv = dnorm2d(x, y, rho)/(dnorm(x) * dnorm(y)) names(c.uv) = NULL # Result: attr(c.uv, "control") <- c(rho = rho) # As List ? if (output == "list") { N = sqrt(length(u)) x = u[1:N] y = matrix(v, ncol = N)[1, ] c.uv = list(x = x, y = y, z = matrix(c.uv, ncol = N)) } # Return Value: c.uv } # ------------------------------------------------------------------------------ .dtCopula <- function(u = 0.5, v = u, rho = 0.75, nu = 4, output = c("vector", "list") ) { # A function implemented by Diethelm Wuertz # Description: # Computes Student-t copula density # Arguments: # see function 'dellipticalCopula' # FUNCTION: # Match Arguments: output = match.arg(output) # Settings: type = "t" if (is.list(u)) { v = u[[2]] u = u[[1]] } if (is.matrix(u)) { v = u[, 2] u = u[, 1] } # Copula Probability: x = qt(u, df = nu) y = qt(v, df = nu) c.uv = dt2d(x, y, rho, nu)/(dt(x, nu) * dt(y, nu)) names(c.uv) = NULL # Result: attr(c.uv, "control") <- c(rho = rho, nu = nu) # As List ? if (output == "list") { N = sqrt(length(u)) x = u[1:N] y = matrix(v, ncol = N)[1, ] c.uv = list(x = x, y = y, z = matrix(c.uv, ncol = N)) } # Return Value: c.uv } # ------------------------------------------------------------------------------ .dcauchyCopula <- function(u = 0.5, v = u, rho = 0.75, nu = 4, output = c("vector", "list") ) { # A function implemented by Diethelm Wuertz # Description: # Computes Student-t copula density # Arguments: # see function 'dellipticalCopula' # FUNCTION: # Cauchy Density: c.uv = .dtCopula(u = u, v = v, rho = rho, nu = 1, output = output) attr(c.uv, "control") <- c(rho = rho) # Return Value: c.uv } # ------------------------------------------------------------------------------ .dellipticalCopulaGrid <- function(N, rho = 0.75, param = NULL, type = ellipticalList(), border = TRUE) { # A function implemented by Diethelm Wuertz # Description: # Computes extreme value copula density # Arguments: # N - the number of grid points is (N+1)*(N+1) # rho - a numeric value setting the coorelation strength, ranging # between minus one and one. # param - additional distributional parameters. # type - the type of the elliptical copula. Either "norm" or # "t" denoting the normal or Student-t copula, respectively. # Value: # returns a vector or list of probabilities depending on the # value of the "output" variable. # Note: # Made for the Sliders. # FUNCTION: # Settings: type = type[1] U = (0:N)/N V = (1:(N-1))/N # Reduce to Grid - speeds up the computation: M = N%/%2 + 1 X = .qelliptical(U[1:M], param = param, type = type) if (N%%2 == 0) { X = c(X, rev(-X)[-1]) } else { X = c(X, rev(-X)) } NX = length(X) x = rep(X, times = NX) y = rep(X, each = NX) D = .delliptical(X, param = param, type = type) DX = rep(D, times = NX) DY = rep(D, each = NX) # Density: c.uv = delliptical2d(x, y, rho = rho, param = param, type = type) / (DX*DY) if (rho == 0 & type == "norm") c.uv[!is.na(c.uv)] = 1 c.uv[is.na(c.uv)] = 0 names(c.uv) = NULL attr(c.uv, "control") <- c(rho = rho) c.uv = list(x = U, y = U, z = matrix(c.uv, ncol = N+1)) if (!border) { c.uv$z = c.uv$z[-1, ] c.uv$z = c.uv$z[-N, ] c.uv$z = c.uv$z[, -1] c.uv$z = c.uv$z[, -N] c.uv = list(x = V, y = V, z = matrix(c.uv$z, ncol = N-1)) } # Return Value: c.uv } # ------------------------------------------------------------------------------ .dellipticalPerspSlider <- function(B = 20) { # A function implemented by Diethelm Wuertz # Description: # Displays interactively perspective plots of density # FUNCTION: # Graphic Frame: par(mfrow = c(1, 1)) # Internal Function: refresh.code = function(...) { # Startup Counter: .counter <- getRmetricsOptions(".counter") + 1 setRmetricsOptions(.counter = .counter) if (.counter < 7) return () # Sliders: Copula = .sliderMenu(no = 1) N = .sliderMenu(no = 2) rho = .sliderMenu(no = 3) nu = .sliderMenu(no = 4) s = .sliderMenu(no = 5) theta = .sliderMenu(no = 6) phi = .sliderMenu(no = 7) r = 1 # Title: Names = c("- Normal", "- Student t", "- Logistic", "- Exponential Power") if (nu == 1) Names[2] = "- Student-t [Cauchy]" if (s == 0.5) Names[4] = "- Exponential Power [Laplace]" if (s == 1) Names[4] = "- Exponential Power [Kotz|Normal]" Title = paste("Elliptical Copula Density No:", as.character(Copula), Names[Copula], "\nrho = ", as.character(rho)) if (Copula == 2) Title = paste(Title, "nu =", as.character(nu)) if (Copula == 4) Title = paste(Title, "s =", as.character(s)) # Plot: uv = grid2d(x = (1:(N-1))/N) Type = c("norm", "t", "logistic", "epower") param = NULL if (Copula == 2) param = nu if (Copula == 4) param = c(r, s) D = .dellipticalCopulaGrid(N, rho = rho, param = param, type = Type[Copula], border = FALSE) Integrated = as.character(round(mean(D$z),2)) Var = var(as.vector(D$z), na.rm = TRUE) if (Var < 1.0e-6) { # A flat perspective plot fails, if zlim is not specified! Mean = round(1.5*mean(as.vector(D$z), na.rm = TRUE), 2) persp(D, theta = theta, phi = phi, col = "steelblue", shade = 0.5, ticktype = "detailed", cex = 0.5, xlab = "u", ylab = "v", zlim = c(0, Mean), zlab = "C(u,v)" ) } else { persp(D, theta = theta, phi = phi, col = "steelblue", shade = 0.5, ticktype = "detailed", cex = 0.5, xlab = "u", ylab = "v", zlab = "C(u,v)" ) } title(main = Title) Tau = as.character(round(2*asin(rho)/pi, 2)) mTitle = paste("Mean: ", Integrated, " | Tau", Tau) mtext(mTitle, side = 4, col = "grey", cex = 0.7) mTitle = paste("1: Normal | 2: Student-t [Cauchy] | 3: Logistic |", "4: Exponential Power [Laplace|Kotz]") mtext(mTitle, side = 1, col = "grey", cex = 0.7) # Reset Frame: par(mfrow = c(1, 1)) } # Open Slider Menu: setRmetricsOptions(.counter = 0) plot.names = c("Plot - theta", "... phi") .sliderMenu(refresh.code, names = c("Copula", "N", "rho", "3: nu", "4: s", plot.names), minima = c( 1, 10, -0.95, 1, 0.1, -180, 0), maxima = c( 4, 100, 0.95, B, 5, 180, 360), resolutions = c( 1, 10, 0.05, 0.1, 0.1, 1, 1), starts = c( 1, 20, 0.50, 4, 1, -40, 30)) } # ------------------------------------------------------------------------------ .dellipticalContourSlider <- function(B = 20) { # A function implemented by Diethelm Wuertz # Description: # Displays interactively perspective plots of density #FUNCTION: # Graphic Frame: par(mfrow = c(1, 1)) # Internal Function: refresh.code = function(...) { # Startup Counter: .counter <- getRmetricsOptions(".counter") + 1 setRmetricsOptions(.counter = .counter) if (.counter < 7) return () # Sliders: Copula = .sliderMenu(no = 1) N = .sliderMenu(no = 2) rho = .sliderMenu(no = 3) nu = .sliderMenu(no = 4) s = .sliderMenu(no = 5) nlev = .sliderMenu(no = 6) ncol = .sliderMenu(no = 7) if (rho == 0 & Copula == 1) return(invisible()) r = 1 # Title: Names = c("- Normal", "- Student t", "- Logistic", "- Exponential Power") if (nu == 1) Names[2] = "- Student-t [Cauchy]" if (s == 0.5) Names[4] = "- Exponential Power [Laplace]" if (s == 1) Names[4] = "- Exponential Power [Kotz|Normal]" Title = paste("Elliptical Copula Density No:", as.character(Copula), Names[Copula], "\nrho = ", as.character(rho)) if (Copula == 2) Title = paste(Title, "nu =", as.character(nu)) if (Copula == 4) Title = paste(Title, "s =", as.character(s)) # Plot: uv = grid2d(x = (0:N)/N) Type = c("norm", "t", "logistic", "laplace", "kotz", "epower") param = NULL if (Copula == 2) param = nu if (Copula == 5) param = r if (Copula == 6) param = c(r, s) D = .dellipticalCopulaGrid(N, rho = rho, param = param, type = Type[Copula], border = FALSE) Integrated = as.character(round(mean(D$z),2)) image(D, col = heat.colors(ncol), ylab = "v", xlim = c(0,1), ylim = c(0,1) ) mtext("u", side = 1, line = 2, cex = 0.7) contour(D, nlevels = nlev, add = TRUE) title(main = Title) Tau = as.character(round(2*asin(rho)/pi, 2)) mTitle = paste("Mean: ", Integrated, " | Tau", Tau) mtext(mTitle, side = 4, col = "grey", cex = 0.7) mTitle = paste("1: Normal | 2: Student-t [Cauchy] | 3: Logistic |", "4: Exponential Power [Laplace|Kotz]") mtext(mTitle, side = 1, line = 3, col = "grey", cex = 0.7) # Reset Frame: par(mfrow = c(1, 1)) } # Open Slider Menu: setRmetricsOptions(.counter = 0) plot.names = c("Plot - levels", "... colors") .sliderMenu(refresh.code, names = c("Copula", "N", "rho", "2: nu", "4: s", plot.names), minima = c( 1, 10, -0.95, 1, 0.1, 5, 12), maxima = c( 4, 100, 0.95, B, 5, 100, 256), resolutions = c( 1, 10, 0.05, 0.1, 0.1, 5, 4), starts = c( 1, 20, 0.50, 4, 1, 10, 32)) } ################################################################################ fCopulae/R/EllipticalDependency.R0000644000176000001440000002605312406047540016455 0ustar ripleyusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA ################################################################################ # FUNCTION: ELLIPTICAL COPULAE DEPENDENCE MASURES: # ellipticalTau Computes Kendall's tau for elliptical copulae # ellipticalRho Computes Spearman's rho for elliptical copulae # FUNCTION: ELLIPTICAL COPULAE TAIL COEFFICIENT: # ellipticalTailCoeff Computes tail dependence for elliptical copulae # ellipticalTailPlot Plots tail dependence function ################################################################################ ################################################################################ # FUNCTION: ELLIPTICAL COPULAE DEPENDENCE MASURES: # ellipticalTau Computes Kendall's tau for elliptical copulae # ellipticalRho Computes Spearman's rho for elliptical copulae ellipticalTau <- function(rho) { # A function implemented by Diethelm Wuertz # Description: # Computes Kendall's tau for elliptical copulae # Arguments: # rho - a numeric value setting the coorelation strength, ranging # between minus one and one. # FUNCTION: # Compute Kendall's Tau: ans = 2 * asin(rho) / pi if (length(rho) == 1) { names(ans) = "Tau" } else { names(ans) = paste("Tau", 1:length(rho), sep = "") } # Add Control Attribute: attr(ans, "control") = c(rho = rho) # Return Value: ans } # ------------------------------------------------------------------------------ .ellipticalRho <- function(rho, param = NULL, type = ellipticalList(), subdivisions = 500) { # A function implemented by Diethelm Wuertz # Description: # Computes Spearman's rho for elliptical copulae # Arguments: # rho - a numeric value setting the coorelation strength, ranging # between minus one and one. # FUNCTION: # Settings: Type = c("Normal Copula", "Cauchy Copula", "Student-t Copula", "Logistic Copula", "Laplace Copula", "Kotz Copula", "Exponential Power Copula") names(Type) = c("norm", "cauchy", "t", "logistic", "laplace", "kotz", "epower") type = type[1] Type = Type[type] # Compute Spearman's Rho: ans.norm = round(6 * asin(rho/2) / pi, 2) # Spearman's Rho: N = subdivisions Pi = pfrechetCopula(u = grid2d((1:(N-1))/N), type = "pi", output = "list") D = .dellipticalCopulaGrid(N = N, rho = rho, param = param, type = type, border = FALSE) ans = round(12*mean(Pi$z*D$z)-3, 2) names(ans) = NULL # Return Value: ans } # ------------------------------------------------------------------------------ ellipticalRho <- function(rho, param = NULL, type = ellipticalList(), subdivisions = 500) { # A function implemented by Diethelm Wuertz # Description: # Computes Spearman's rho for elliptical copulae # Arguments: # rho - a numeric value setting the coorelation strength, ranging # between minus one and one. # FUNCTION: # Match Arguments: type = match.arg(type) # For all Values of rho: ans = NULL for (i in 1:length(rho)) { ans = c(ans, .ellipticalRho(rho[i], param, type, subdivisions)) } # Add Control Attribute: control = c( rho = rho, param = param, type = type, tau = round(2*asin(rho)/pi, 4)) attr(ans, "control")<-unlist(control) if (length(rho) == 1) { names(ans) = "Rho" } else { names(ans) = paste("Rho", 1:length(rho), sep = "") } # Return Value: ans } ################################################################################ # FUNCTION: ELLIPTICAL COPULAE TAIL COEFFICIENT: # ellipticalTailCoeff Computes tail dependence for elliptical copulae # ellipticalTailPlot Plots tail dependence function ellipticalTailCoeff <- function(rho, param = NULL, type = c("norm", "cauchy", "t")) { # A function implemented by Diethelm Wuertz # Description: # Computes tail dependence for elliptical copulae # Arguments: # rho - a numeric value setting the coorelation strength, ranging # between minus one and one. # Note: # type = c("logistic", "laplace", "kotz", "epower") # not yet implemented # FUNCTION: # Check: stopifnot(length(rho) == 1) # Match Arguments: type = match.arg(type) # Compute Tail Dependence: if (type == "norm") { lambda = 0 param = NULL } if (type == "cauchy") { nu = 1 arg = sqrt(nu+1) * sqrt(1-rho) / sqrt(1+rho) lambda = 2 * (1 - pt(arg, df = nu+1)) param = NULL } if (type == "t") { nu = param if (is.null(nu)) nu = 4 arg = sqrt(nu+1) * sqrt(1-rho) / sqrt(1+rho) lambda = 2 * (1 - pt(arg, df = nu+1)) param = c(nu = nu) } if (type == "logistic") { lambda = NA param = NULL } if (type == "laplace") { lambda = NA param = NULL } if (type == "kotz") { lambda = NA param = NULL } if (type == "epower") { lambda = NA param = NULL } # Result: ans = c(lambda = lambda) attr(ans, "control") = c(rho = rho, type = type, param = param) # Return Value: ans } # ------------------------------------------------------------------------------ ellipticalTailPlot <- function(param = NULL, type = c("norm", "cauchy", "t"), tail = c("Lower", "Upper")) { # A function implemented by Diethelm Wuertz # Description: # Plots tail dependence for elliptical copulae # Arguments: # rho - a numeric value setting the coorelation strength, ranging # between minus one and one. # Note: # type = c("logistic", "laplace", "kotz", "epower") # not yet implemented # FUNCTION: # Match Arguments: type = match.arg(type) tail = match.arg(tail) # Settings: Title = c("Normal", "Cauchy", "Student-t", "Logistic", "Laplace", "Kotz", "Exponential Power") Title = paste(Title, "Copula") names(Title) = c("norm", "cauchy", "t", "logistic", "laplace", "kotz", "epower") Title = Title[type] tail = tail[1] N = 1000; Points = 20 # don't change these values! u = (0:N)/N SHOW = N+1 # Parameters: if (type == "t" & is.null(param)) { param = c(nu = 4) } if (type == "kotz" & is.null(param)) { param = c(r = 1) } if (type == "epower" & is.null(param)) { param = c(r = 1, s = 1) } # Plot Frame: if (type == "t") Title = paste(Title, "| nu =", as.character(param)) if (type == "t") Title = paste(Title, "| r =", as.character(param)) if (type == "epower") Title = paste(Title, "| r =", as.character(param[1]), " s =", as.character(param[2])) plot(c(0,1), c(0,1), type = "n", main = Title, xlab = "u", ylab = paste(tail, "Tail Dependence")) # Cauchy Tail dependence: if (type == "cauchy") { type = "t" param = c(nu = 1) } # Iterate rho: Rho = c(-0.99, seq(-0.9, 0.9, by = 0.3), 0.99) for (rho in Rho) { # Compute Tail Coefficient: lambda = ellipticalTailCoeff(rho = rho, param = param, type = type) # Compute Copula Cross Section C(u,u)" if (type == "norm") C.uu = pellipticalCopula(u, rho = rho, type = type) if (type == "t") C.uu = .ptCopula(u = u, v = u, rho = rho, nu = param) if (type == "logistic" | type == "laplace" | type == "kotz" | type == "epower") C.uu = .pellipticalCopulaDiag(N, rho = rho, param = param, type = type)$y # Compute Copula Tail dependence lambda: if (tail == "Upper") { lambdaTail = (1-2*u+C.uu)/(1-u) } else if (tail == "Lower") { lambdaTail = C.uu/u } # Define Plot Elements: if (abs(rho) < 0.05) { color = "black" linetype = 1 } else if (abs(rho) > 0.95) { color = "blue" linetype = 1 } else { color = "black" linetype = 3 } # Normal Tail Dependence: if (type == "norm") { lines(u, lambdaTail, lty = linetype, col = color) } # Cauchy and Student-t Tail Dependence: if (type == "t") { if (tail == "Upper") lines(u[u < 0.99], lambdaTail[u < 0.99], lty = linetype, col = color) if (tail == "Lower") lines(u[u > 0.01], lambdaTail[u > 0.01], lty = linetype, col = color) } # Logistic Tail dependence: if (type == "logistic" | type == "laplace" | type == "kotz") { if (tail == "Lower") { SHOW = which.min(lambdaTail[-1]) ## lines(u[SHOW:(N+1)], lambdaTail[SHOW:(N+1)], type = "l", lty = linetype, col = color) } if (tail == "Upper") { SHOW = which.min(lambdaTail[-(N+1)]) lines(u[1:SHOW], lambdaTail[1:SHOW], type = "l", lty = linetype, col = color) } } # Add rho Labels text(x = 0.5, y = lambdaTail[floor(N/2)]+0.05, col = "red", cex = 0.7, labels = as.character(round(rho, 2))) # Add Points to Curves: if (tail == "Upper") { M = min(SHOW, N) Index = seq(1, M, by = Points) X = 1 } else if (tail == "Lower") { M = max(51, SHOW) Index = rev(seq(N+1, M, by = -Points)) X = 0 } points(u[Index], lambdaTail[Index], pch = 19, cex = 0.7) # Add Tail Coefficient: points(x = X, y = lambda[1], pch = 19, col = "red") } points(1, 0, pch = 19, col = "red") abline(h = 0, lty = 3, col = "grey") abline(v = X, lty = 3, col = "grey") # Return Value: invisible() } ################################################################################ fCopulae/R/aaaCopulaeEnv.R0000644000176000001440000000275012406047540015076 0ustar ripleyusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA ############################################################################### .fCopulaeEnv <- new.env(hash = TRUE) .setfCopulaeEnv <- function(...) { x <- list(...) nm <- names(x) if (is.null(nm) || "" %in% nm) stop("all arguments must be named") sapply(nm, function(nm) assign(nm, x[[nm]], envir = .fCopulaeEnv)) invisible() } .getfCopulaeEnv <- function(x = NULL, unset = "") { if (is.null(x)) x <- ls(all.names = TRUE, envir = .fCopulaeEnv) ### unlist(mget(x, envir = .fCopulaeEnv, mode = "any", ### ifnotfound = as.list(unset)), recursive = FALSE) get(x, envir = .fCopulaeEnv, mode = "any") } ############################################################################### fCopulae/R/ExtremeValueModelling.R0000644000176000001440000000627412406047540016640 0ustar ripleyusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA ################################################################################ # FUNCTION: EXTREME VALUE COPULA PARAMETER FITTING: # evCopulaSim Simulates bivariate extreme value copula # evCopulaFit Fits the paramter of an extreme value copula ################################################################################ ################################################################################ # FUNCTION: EXTREME VALUE COPULA PARAMETER FITTING: # evCopulaSim Simulates bivariate extreme value copula # evCopulaFit Fits the paramter of an extreme value copula evCopulaSim = function(n, param = NULL, type = evList()) { # A function implemented by Diethelm Wuertz # Description: # Simulates bivariate extreme value Copula # FUNCTION: # Match Arguments: type = match.arg(type) # Settings: if (is.null(param)) param = evParam(type)$param # Random Variates: ans = revCopula(n = n, param = param, type = type) # Return Value: ans } # ------------------------------------------------------------------------------ evCopulaFit = function(u, v = NULL, type = evList(), ...) { # A function implemented by Diethelm Wuertz # Description: # Fits the paramter of an elliptical copula # Note: # The upper limit for nu is 100 # FUNCTION: # Match Arguments: type = match.arg(type) # Settings: U <<- u V <<- v if (is.list(u)) { U <<- u[[1]] V <<- u[[2]] } if (is.matrix(u)) { U = u[, 1] V = u[, 2] } # Start Values: param = evParam(type)$param range = evRange(type) paramLength = length(param) # Log-Likelihood Function: .fun = function(x, type) { -mean( log(devCopula(u = U, v = V, param = x, type = type)) ) } if (paramLength == 1) { # We have only one parameter to optimize ... fit = optimize(f = .fun, lower = range[1], upper = range[2], maximum = FALSE, tol = .Machine$double.eps^0.25, type = type, ...) } else { # Log-Likelihood Function: range = evRange(type) fit = nlminb(start = param, objective = .fun, lower = range[1], upper = range[2], type = type, ...) } # Return Value: fit } ################################################################################ fCopulae/R/ArchimedeanDependency.R0000644000176000001440000003663212406047540016577 0ustar ripleyusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA ################################################################################ # FUNCTION: KENDALL'S TAU AND SPEARMAN'S RHO: # archmTau Returns Kendall's tau for Archemedean copulae # archmRho Returns Spearman's rho for Archemedean copulae # .archmTauRange Returns range for Kendall's tau # .archm2Tau Alternative way to compute Kendall's tau # ### .archmGamma Returns Gini's gamma for Archimedean copulae # .archmTail Utility Function # FUNCTION: ARCHIMEDEAN COPULAE TAIL COEFFICIENT: # archmTailCoeff Computes tail dependence for Archimedean copulae # archmTailPlot Plots Archimedean tail dependence function # REQUIREMENT: DESCRIPTION: # adapt Contributed R package adapt ################################################################################ ################################################################################ # FUNCTION KENDALL'S TAU AND SPEARMAN'S RHO: # archmTau Returns Kendall's tau for Archemedean copulae # archmRho Returns Spearman's rho for Archemedean copulae # .archmTauRange Returns range for Kendall's tau # .archm2Tau Alternative way to compute Kendall's tau # .archmGamma Returns Gini's gamma for Archimedean copulae # .archmTail Utility Function archmTau <- function(alpha = NULL, type = archmList(), lower = 1.0e-10) { # A function implemented by Diethelm Wuertz # Description: # Kendall's tau by integration for Archimedean copulae # FUNCTION: # Settings: type = match.arg(type) Type = as.integer(type) # Alpha: if (is.null(alpha)) alpha = archmParam(type)$param # Check alpha: check = archmCheck(alpha, type) # Compute tau: if (length(alpha) == 1) { ans = .archmTau(alpha, type, lower) names(ans) = "Tau" names(alpha) = "alpha" } else { ans = NULL for ( i in 1:length(alpha) ) ans = c(ans, .archmTau(alpha[i], type, lower)[1]) names(ans) = paste("Tau", 1:length(alpha), sep = "") names(alpha) = paste("alpha", 1:length(alpha), sep = "") } # Add Control Attribute: attr(ans, "control")<-cbind.data.frame( t(alpha), type = type, lower = lower, row.names= "") # Return Value: ans } # ------------------------------------------------------------------------------ .archmTau <- function(alpha = NULL, type = archmList(), lower = 1.0e-10) { # A function implemented by Diethelm Wuertz # Description: # Kendall's tau by integration for Archimedean copulae # FUNCTION: # Type: type <- match.arg(type) Type <- as.integer(type) # Alpha: if (is.null(alpha)) alpha = archmParam(type)$param # Check alpha: check = archmCheck(alpha, type) # Select Type: if (Type == 1) { if (alpha == -1) return(-1) if (alpha == 0) return(0) tau = alpha/(alpha+2) return(tau) } else if (Type == 2) { if (alpha == 1) return(-1) tau = 1 - 2/alpha return(tau) } else if (Type == 3 & alpha == 0) { return(0) # tau numeric } else if (Type == 3 & alpha == 1) { return(1/3) # tau numeric } else if (Type == 4) { if (alpha == 1) return(0) tau = 1 - 1/alpha return(tau) } else if (Type == 5 & alpha == 0) { return(0) # tau numeric } else if (Type == 6 & alpha == 1) { return(0) } else if (Type == 7) { if (alpha == 0) return(1) if (alpha == 1) return(0) tau = 2*(1-alpha)*(alpha+log(1-alpha)-alpha*log(1-alpha))/alpha^2 return(tau) } else if (Type == 8) { if (alpha == 1) return(-1) tau = (-4+alpha)/(3*alpha) return(tau) } else if (Type == 9 & alpha == 0) { return(0) # tau numeric } else if (Type == 10 & alpha == 0) { return(0) # tau numeric } else if (Type == 11 & alpha == 0) { return(0) } else if (Type == 12) { tau = 1 - 2/(3*alpha) return(tau) } else if (Type == 13 & alpha == 1) { return(0) # tau numeric } else if (Type == 13 & alpha == 0) { return(-0.3613289) # 1e-8 value } else if (Type == 14) { tau = 1 - 4/(2+4*alpha) return(tau) } else if (Type == 15) { if (alpha == 1) return(-1) tau = 1 + 4/(2-4*alpha) return(tau) } else if (Type == 16 & alpha == 0) { return(-1) # tau numeric } else if (Type == 17 & alpha == -1) { return(0) # tau numeric } else if (Type == 18) { tau = 1 - 4/(3*alpha) return(tau) } else if (Type == 19 & alpha == 0) { return(0) # tau numeric } else if (Type == 20 & alpha == 0) { return(1/3) # tau numeric # } else if (Type == 21) { # tau numeric # } else if (Type == 22) { # tau numeric } else { # Integrate: ans = integrate( f = .Kfunc, lower = lower, upper = 1, alpha = alpha, type = type, stop.on.error = FALSE, rel.tol = .Machine$double.eps^0.5) tau = 3 - 4 * ans[[1]] attr(tau, "control")<-unlist(c(alpha, type = type, ans[2:4])) return(tau) } # Return Value: invisible() } # ------------------------------------------------------------------------------ .archmTauRange <- function(type = archmList()) { # A function implemented by Diethelm Wuertz # FUNCTION: # Type: type = match.arg(type) Type = as.integer(type) # Range: range = matrix( c( 1, -1, 1, 2, -1, 1, 3, -0.182, 1/3, 4, 0, 1, 5, -1, 1, 6, 0, 1, 7, 0, 1, 8, -1, 1/3, 9, 0, 0.361, 10, 0, 0.182, 11, 0,-0.565, 12, 1/3, 1, 13, 0.361, NA, 14, 1/3, 1, 15, -1, 1, 16, NA, 1/3, 17, -1, 1, 18, 1/3, 1, 19, 1/3, 1, 20, 0, 1, 21, NA, NA, 22, NA, NA ), byrow = TRUE, ncol = 3 ) # Result: ans <- range[Type, ][-1] names(ans) <- c("tau.lower", "tau.upper") attr(ans, "control") <- c(type = type) # Return Value: ans } # ------------------------------------------------------------------------------ .archm2Tau <- function (alpha = NULL, type = archmList(), lower = 1e-6) { # A function implemented by Diethelm Wuertz # Joe's [1997] alternative expression: # Type: type = match.arg(type) Type = as.integer(type) # Alpha: if (is.null(alpha)) alpha = archmParam(type)$param # Check alpha: check = archmCheck(alpha, type) # Integrate: K2func = function(x, alpha, type) { x * .invPhiFirstDer(x, alpha, type)^2 } upper = .Phi(0, alpha, type) - lower ans = integrate(f = K2func, lower = lower, upper = upper, alpha = alpha, type = type) tau = 1 - 4 * ans[[1]] attr(tau, "control") <- unlist(c(alpha, type = type, ans[2:4])) # Return Value: tau } # ------------------------------------------------------------------------------ archmRho <- function(alpha = NULL, type = archmList(), method = c("integrate2d", "adapt"), error = 1.0e-5) { # A function implemented by Diethelm Wuertz # Description: # Spearman's Rho by integration for Archimedean copulae # FUNCTION: # Match Arguments: method = match.arg(method) # Type: type = match.arg(type) Type = as.integer(type) # Alpha: if (is.null(alpha)) alpha = archmParam(type)$param # Check alpha: check = archmCheck(alpha, type) # Compute Rho: if (length(alpha) == 1) { ans = .archmRho(alpha, type, method, error) names(ans) = "Rho" names(alpha) = "alpha" } else { ans = NULL for ( i in 1:length(alpha) ) ans = c(ans, .archmRho(alpha[i], type, method, error)[1]) names(ans) = paste("Rho", 1:length(alpha), sep = "") names(alpha) = paste("alpha", 1:length(alpha), sep = "") } # Add Control Attribute: attr(ans, "control")<-cbind.data.frame( t(alpha), type = type, method = method, error = error, row.names= "") # Return Value: ans } # ------------------------------------------------------------------------------ .archmRho <- function(alpha = NULL, type = archmList(), method = c("integrate2d", "adapt"), error = 1.0e-5) { # A function implemented by Diethelm Wuertz # Description: # Spearman's rho by integration for Archimedean copulae # Requirements: # Note, method="adapt" requires R-Package adapt # FUNCTION: # Match Arguments: method <- match.arg(method) # Type: type <- match.arg(type) Type <- as.integer(type) # Alpha: if (is.null(alpha)) alpha = archmParam(type)$param # Check alpha: check = archmCheck(alpha, type) # Global Parameters: ## alpha <<- alpha ## type <<- type # 2D Integration: if (method == "integrate2d" ) { # Internal Function : fun.integrate2d = function(x, y, alpha, type ) { 12 * (.parchm1Copula(x, y, alpha = alpha, type = type) - x*y ) } ans = integrate2d(fun.integrate2d, error = error, alpha = alpha, type = type) } else if (method == "adapt") { # Requires contributed package adapt ... fun.adapt = function(z, alpha, type) { x = z[1] y = z[2] 12 * (.parchm1Copula(x, y, alpha = alpha, type = type) - x*y) } ans = adapt(ndim = 2, lower = c(0, 0), upper = c(1, 1), minpts = 100, maxpts = NULL, functn = fun.adapt, eps = 0.01, alpha = alpha, type = type) } rho = ans$value # Result: control = list(alpha = alpha[[1]]) attr(rho, "control") <- unlist(control) # Return Value: rho } # ------------------------------------------------------------------------------ # .archmGamma <- # function(alpha = 0.5, type = archmList()) # { # A function implemented by Diethelm Wuertz # # # Description: # # Gini's gamma by integration for Archimedean copulae # # # FUNCTION: # # # Type: # type = match.arg(type) # Type = as.integer(type) # # # Check alpha: # check = archmCheck(alpha, type) # # # Specification: # spec = copulaSpec("archm", model = list(alpha = alpha, type = type)) # # # Internal Function: # fun = function(x, spec) { # f = NULL # for ( y in x ) # f = c( f, 4*(pcopula(y, y, spec) + pcopula(y, 1-y, spec) - y) ) # f } # # # Integration: # ans = integrate(fun, c(0, 0), c(1, 1), spec = spec) # # # Result: # gamma = ans$value # attr(gamma, "control") <- unlist(ans[-1]) # # # Return Value: # gamma # } ################################################################################ # FUNCTION: ARCHIMEDEAN COPULAE TAIL COEFFICIENT: # archmTailCoeff Computes tail dependence for Archimedean copulae # archmTailPlot Plots Archimedean tail dependence function archmTailCoeff <- function(alpha = NULL, type = archmList()) { # A function implemented by Diethelm Wuertz # Description: # Tail Dependence for Archimedean copulae # FUNCTION: # Type: type = match.arg(type) Type = as.integer(type) # Alpha: if (is.null(alpha)) alpha = archmParam(type)$param # Check alpha: check = archmCheck(alpha, type) # Tail Coefficient: N = 20 x = 1 - (1/2)^(1:N) lambdaU.Cuv = ( 1 - 2*x + parchmCopula(u = x, v = x, alpha = alpha, type = type) ) / (1-x) lambdaU.Phi = 2 - 2 * .invPhiFirstDer(2*x, alpha = alpha, type = type) / .invPhiFirstDer(x, alpha = alpha, type = type) # Return Value: list(lambdaU.Cuv = lambdaU.Cuv, lambdaU.Phi = lambdaU.Phi) } # ------------------------------------------------------------------------------ archmTailPlot <- function(alpha = NULL, type = archmList(), tail = c("Upper", "Lower")) { # A function implemented by Diethelm Wuertz # Description: # Plots tail dependence for elliptical copulae # Arguments: # rho - a numeric value setting the coorelation strength, ranging # between minus one and one. # FUNCTION: # Match Arguments: type = match.arg(type) Type = as.integer(type) tail = match.arg(tail) # Settings: Title = paste("Archimedean Copula No.", 1:22) names(Title) = paste(1:22) Title = Title[type] N = 1000; Points = 20 # don't change these values! u = (0:N)/N # Plot Frame: plot(c(0, 1), c(0, 1), type = "n", main = Title, xlab = "u", ylab = paste(tail, "Tail Dependence")) # Iterate alpha: B = 10 lower = max(archmRange(type)[1], -B) upper = min(archmRange(type)[2], B) # Select alpha: if (is.null(alpha)) { # from range: Alpha = seq(lower, upper, length = 5) } else { # from arguments: Alpha = alpha } # Do for all alpha: for (alpha in Alpha) { # Compute Copula Tail dependence lambda: C.uu = parchmCopula(u, alpha = alpha, type = type) if (tail == "Upper") { lambdaTail = (1-2*u+C.uu)/(1-u) } else if (tail == "Lower") { lambdaTail = C.uu/u } # Add Parameter Labels: text(x = 0.52, y = lambdaTail[floor(N/2)]+0.025, col = "red", cex = 0.7, labels = as.character(round(alpha, 2))) # Add Lines: lines(u, lambdaTail, lty = 3, col = "black") # Add Points to Curves: if (tail == "Upper") { Index = round(seq(1, N-1, length = Points)) X = 1 } else if (tail == "Lower") { Index = round(seq(1, N-1, length = Points)) + 1 X = 0 } points(u[Index], lambdaTail[Index], col = "steelblue", pch = 19, cex = 0.7) } abline(h = 0, lty = 3, col = "grey") abline(v = X, lty = 3, col = "grey") # Return Value: invisible() } ################################################################################ fCopulae/R/ExtremeValueDependency.R0000644000176000001440000002425612406047540017004 0ustar ripleyusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA ################################################################################ # FUNCTION KENDALL'S TAU AND SPEARMAN'S RHO: # evTau Returns Kendall's tau for extreme value copulae # .ev1Tau Computes Kendall's tau from dependency function # .ev2Tau Computes Kendall's tau from integration # evRho Returns Spearman's rho for extreme value copulae # .ev1Rho Computes Spearman's rho from dependency function # .ev2Rho Computes Spearman's rho from integration # FUNCTION: EXTREME VALUE COPULAE TAIL DEPENDENCE: # evTailCoeff Computes tail dependence for extreme value copulae # evTailCoeffSlider Plots extreme value tail dependence function ################################################################################ ################################################################################ # FUNCTION KENDALL'S TAU AND SPEARMAN'S RHO: # evTau Returns Kendall's tau for extreme value copulae # evRho Returns Spearman's rho for extreme value copulae evTau = function(param = NULL, type = evList(), alternative = FALSE) { # A function implemented by Diethelm Wuertz # Description: # Computes Kendall's tau for an extreme value copula # Example: # evTau(alternative = FALSE) # evTau(alternative = TRUE) # FUNCTION: # Kendall's Tau: if (!alternative) { # Default Method: ans = .ev1Tau(param, type) } else { # Alternative Method: ans = .ev2Tau(param, type) } # Return Value: ans } # ------------------------------------------------------------------------------ .ev1Tau = function(param = NULL, type = evList()) { # A function implemented by Diethelm Wuertz # Description: # Computes Kendall's tau from dependency function # FUNCTION: # Type: type = match.arg(type) # Default Parameters: if (is.null(param)) param = evParam(type)$param # Kendall's Tau Integrand: fun = function(x, param, type) { # To be integrated from 0 to 1 ... A = Afunc(x = x, param = param, type = type) A2 = .AfuncSecondDer(x, param, type) f = (x*(1-x)/A) * A2 f } # Get control attribute from: attribute = Afunc(0.5, param, type) # Integrate: ans = integrate(fun, 0, 1, param = param, type = type) Tau = c(Tau = ans[[1]]) # Add Control Attribute: attr(Tau, "control")<-attr(attribute, "control") # Return Value: Tau } # ------------------------------------------------------------------------------ .ev2Tau = function(param = NULL, type = evList()) { # A function implemented by Diethelm Wuertz # Description: # Computes Kendall's tau from integration # Example: # .ev2Tau() # FUNCTION: # Type: type = match.arg(type) # Default Parameters: if (is.null(param)) param = evParam(type)$param # Kendall's Tau Minus Rho/3 Double Integrand: fun = function(x, y, ...) { D = devCopula(x, y, alternative = FALSE, ...) D[is.na(D)] = 0 f = 4 * ( pevCopula(x, y, alternative = FALSE, ...) - x*y) * D f } # Get control attribute from: attribute = Afunc(0.5, param, type) # Integrate: ans = integrate2d(fun, param = param, type = type, error = 1e-8) Tau = c(Tau = ans[[1]] + .ev2Rho(param, type)/3) # Add Control Attribute: attr(Tau, "control")<-attr(attribute, "control") # Return Value: Tau } # ------------------------------------------------------------------------------ evRho = function(param = NULL, type = evList(), alternative = FALSE) { # A function implemented by Diethelm Wuertz # Description: # Computes Spearman's rho for an extreme value copula # Example: # evRho(alternative = FALSE) # evRho(alternative = TRUE) # FUNCTION: # Spearman's Rho: if (!alternative) { # Default Method: ans = .ev1Rho(param, type) } else { # Alternative Method: ans = .ev2Rho(param, type) } # Return Value: ans } # ------------------------------------------------------------------------------ .ev1Rho = function(param = NULL, type = evList()) { # A function implemented by Diethelm Wuertz # Description: # Computes Spearman's rho from dependency function # Example: # .ev1Rho() # FUNCTION: # Type: type = match.arg(type) # Default Parameters: if (is.null(param)) param = evParam(type)$param # Spearman's Rho Integrand: fun = function(x, param, type) { # To be integrated from 0 to 1 ... A = Afunc(x = x, param = param, type = type) f = ( 12 / (A+1)^2 ) - 3 f } # Get control attribute from: attribute = Afunc(0.5, param, type) # Integrate: ans = integrate(fun, 0, 1, param = param, type = type) Rho = c(Rho = ans[[1]]) # Add Control Attribute: attr(Rho, "control")<-attr(attribute, "control") # Return Value: Rho } # ------------------------------------------------------------------------------ .ev2Rho = function(param = NULL, type = evList()) { # A function implemented by Diethelm Wuertz # Description: # Computes Spearman's rho from integration # Example: # .ev2Rho() # FUNCTION: # Type: type = match.arg(type) # Default Parameters: if (is.null(param)) param = evParam(type)$param # Spearman's Rho Integrand: fun = function(x, y, ...) { f = 12 * pevCopula(x, y, ...) - 3 f } # Get control attribute from: attribute = Afunc(0.5, param, type) # Integrate: ans = integrate2d(fun, param = param, type = type) Rho = c(Rho = ans[[1]]) # Add Control Attribute: attr(Rho, "control")<-attr(attribute, "control") # Return Value: Rho } ################################################################################ # FUNCTION: EXTREME VALUE COPULAE TAIL DEPENDENCE: # evTailCoeff Computes tail dependence for extreme value copulae # evTailCoeffSlider Plots extreme value tail dependence function evTailCoeff = function(param = NULL, type = evList()) { # A function implemented by Diethelm Wuertz # Description: # Tail Dependence for extreme value copulae # Example: # evTailCoeff() # FUNCTION: # Type: type = match.arg(type) # Default Parameters: if (is.null(param)) param = evParam(type)$param # Limit: lambdaU = 2-2*Afunc(0.5, param, type)[[1]] lambdaL = 0 ans = c(lower = lambdaL, upper = lambdaU) # Add Control Attribute: attr(ans, "control") <- unlist(list(copula = "ev", param = param, type = type)) # Return Value: ans } # ------------------------------------------------------------------------------ evTailCoeffSlider = function(B = 10) { # A function implemented by Diethelm Wuertz # Description: # Displays interactively perspective plots of tail coefficient # Example: # evTailCoeffSlider() # FUNCTION: # Graphic Frame: par(mfrow = c(1, 1)) # Internal Function: refresh.code = function(...) { # Startup: .counter <- getRmetricsOptions(".counter") + 1 setRmetricsOptions(.counter = .counter) if (.counter < 10) return() # Sliders: Type = evList() Copula = .sliderMenu(no = 1) N = .sliderMenu(no = 2) if (Copula <= 3) param = c(delta = .sliderMenu(no = Copula + 2)) if (Copula == 4) param = c(alpha = .sliderMenu(no = 6), beta = .sliderMenu(no = 7), r = .sliderMenu(no = 8)) if (Copula == 5) param = c(delta = .sliderMenu(no = 9), theta = .sliderMenu(no = 10)) # Title: type = Type[Copula] subTitle = paste(paste(names(param) , "="), param, collapse = " | " ) Title = paste(" ", type, "\n", subTitle) # Plot: u = seq(0, 0.5, length = N+1)[-1] C.uu = pevCopula(u, u, param, type) lambda = C.uu/u v = seq(0.5, 1, length = N+1)[-(N+1)] C.uu = pevCopula(v, v, param, type) lambda = c(lambda, (1-2*v+C.uu)/(1-v)) x = c(u, v) plot(x, lambda, xlim = c(0, 1), ylim = c(0, 1), pch = 19, col = "steelblue", xlab = "u") title(main = Title) grid() # Add Points: points(x = 0, y = 0, pch = 19, col = "red") points(x = 1, y = 2-2*Afunc(0.5, param, type), pch = 19, col = "red") # Lines: abline(h = 0, col = "grey") abline(v = 0.5, col = "grey") # Reset Frame: par(mfrow = c(1, 1)) } setRmetricsOptions(.counter = 0) # Open Slider Menu: C = c("1 Gumbel: delta", "2 Galambos: delta", "3 Husler-Reis: delta", "4 Tawn: alpha", "... beta", "... r", "5 BB5: delta", "... theta") .sliderMenu(refresh.code, names = c("Copula", "N", C), # N gumbel galamb h.r tawn-tawn-tawn bb5-bb5 minima = c(1, 10, 1, 0, 0, 0, 0, 1, 0, 1), maxima = c(5, 100, B, B, B, 1, 1, B, B, B), resolutions = c(1, 10, .05, .05, .05, .01, .01, .1, .1, .1), starts = c(1, 20, 2, 1, 1, .5, .5, 2, 1, 2)) } ################################################################################ fCopulae/R/EllipticalGenerator.R0000644000176000001440000014600312406047540016323 0ustar ripleyusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA ################################################################################ # FUNCTION: UTILITY FUNCTIONS: # ellipticalList Returns list of implemented Elliptical copulae # ellipticalParam Sets default parameters for an elliptical copula # ellipticalRange Returns the range of valid rho values # ellipticalCheck Checks if rho is in the valid range # FUNCTION: ELLIPTICAL GENERATOR AND RELATED FUNCTIONS: # gfunc Generator function for elliptical distributions # gfuncSlider Slider for generator, density and probability # .pelliptical Univariate elliptical distribution probability # .delliptical Univariate elliptical distribution density # .qelliptical Univariate elliptical distribution quantiles # .qlogistic Fast tabulated logistic quantile function # .qlogisticData Table generator for logistic quantiles # .qlogisticTable Table for logistic quantiles ################################################################################ ################################################################################ # UTILITY FUNCTIONS: # ellipticalParam Sets Default parameters for an elliptical copula # ellipticalList Returns list of implemented Elliptical copulae # ellipticalRange Returns the range of valid rho values # ellipticalCheck Checks if rho is in the valid range ellipticalList <- function() { # A function implemented by Diethelm Wuertz # Description: # Returns list of implemented elliptical copulae # Arguments: # FUNCTION: # Compose List: ans = c("norm", "cauchy", "t", "logistic", "laplace", "kotz", "epower") # Return Value: ans } # ------------------------------------------------------------------------------ ellipticalParam <- function(type = ellipticalList()) { # A function implemented by Diethelm Wuertz # Description: # Sets default parameters for elliptical copulae # Arguments: # type - a character string denoting the type of distribution. # This may be either # "norm" for the normal distribution, or # "cauchy" for the Cauchy distribution, or # "t" for the Student-t distribution, or # "logistic" for the logistic distribution, or # "laplace" for the distribution, or # "kotz" for the original Kotz distribution, or # "epower" for the exponential power distribution # Value: # returns a list with two elements, 'param' sets the parameters # which may be a vector, 'range' the range with minimum and # maximum values for each of the parameters. # Example: # ellipticalParam("norm"); ellipticalParam("t") # FUNCTION: # Settings: type = match.arg(type) # Parameter Values: # ("norm", "cauchy", "t", "logistic", "laplace", "kotz", "epower") lower = c( -1, -1, -1, -1, -1, -1, -1) upper = c( +1, +1, +1, +1, +1, +1, +1) rho = c(3/4, 3/4, 3/4, 3/4, 3/4, 3/4, 3/4) param1 = c( NA, NA, 4, NA, NA, 1, 1) param2 = c( NA, NA, NA, NA, NA, NA, 1) # Create Parameter List: ans = list(type = type) if (type == "norm") { ans$param = c(rho = rho[1]) ans$range = c(lower = lower[1], upper = upper[1]) } if (type == "cauchy") { ans$param = c(rho = rho[2]) ans$range = c(lower = lower[2], upper = upper[2]) } if (type == "t") { ans$param = c(rho = rho[3], nu = param1[3]) ans$range = c(lower = lower[3], upper = upper[3]) } if (type == "logistic") { ans$param = c(rho = rho[4]) ans$range = c(lower = lower[4], upper = upper[4]) } if (type == "laplace") { ans$param = c(rho = rho[5]) ans$range = c(lower = lower[5], upper = upper[5]) } if (type == "kotz") { ans$param = c(rho = rho[6], r = param1[6]) ans$range = c(lower = lower[6], upper = upper[6]) } if (type == "epower") { ans$param = c(rho = rho[7], r = param1[7], s = param2[7]) ans$range = c(lower = lower[7], upper = upper[7]) } # Return Value: ans } # ------------------------------------------------------------------------------ ellipticalRange <- function(type = ellipticalList()) { # A function implemented by Diethelm Wuertz # Description: # Returns the range of valid alpha values # Arguments: # type - a character string denoting the type of distribution. # This may be either # "norm" for the normal distribution, or # "cauchy" for the Cauchy distribution, or # "t" for the Student-t distribution, or # "logistic" for the logistic distribution, or # "laplace" for the distribution, or # "kotz" for the original Kotz distribution, or # "epower" for the exponential power distribution # Example: # ellipticalRange("norm"); ellipticalRange("t") # FUNCTION: # Type: type = match.arg(type) # Range: ans = ellipticalParam(type)$range attr(ans, "control") <- type # Return Value: ans } # ------------------------------------------------------------------------------ ellipticalCheck <- function(rho = 0.75, param = NULL, type = ellipticalList()) { # A function implemented by Diethelm Wuertz # Description: # Checks if alpha is in the valid range # Arguments: # rho - correlation coefficient # param - currently not used # type - a character string denoting the type of distribution. # This may be either # "norm" for the normal distribution, or # "cauchy" for the Cauchy distribution, or # "t" for the Student-t distribution, or # "logistic" for the logistic distribution, or # "laplace" for the distribution, or # "kotz" for the original Kotz distribution, or # "epower" for the exponential power distribution # Example: # ellipticalCheck(0.5, NULL, "norm") # ellipticalCheck(1.5, NULL, "t") # FUNCTION: # Type: type = match.arg(type) # Range: range = as.vector(ellipticalRange(type)) if (rho < range[1] | rho > range[2]) { print(c(rho = rho)) print(c(range = range)) stop("rho is out of range") } # Return Value: invisible() } ################################################################################ # FUNCTION: ELLIPTICAL GENERATOR AND RELATED FUNCTIONS: # gfunc Generator function for elliptical distributions # gfuncSlider Slider for generator, density and probability # .pelliptical Univariate elliptical distribution probability # .delliptical Univariate elliptical distribution density # .qelliptical Univariate elliptical distribution quantiles # .qlogistic Fast tabulated logistic quantile function # .qlogisticData Table generator for logistic quantiles # .qlogisticTable Table for logistic quantiles gfunc <- function(x, param = NULL, type = ellipticalList()) { # A function implemented by Diethelm Wuertz # Description: # Generator function for elliptical distributions # Arguments: # x - a numeric vector # param - NULL, a numeric value, or a numeric vector adding. # additional parameters to the generator function. # type - a character string denoting the type of distribution. # This may be either # "norm" for the normal distribution, or # "cauchy" for the Cauchy distribution, or # "t" for the Student-t distribution, or # "logistic" for the logistic distribution, or # "laplace" for the distribution, or # "kotz" for the original Kotz distribution, or # "epower" for the exponential power distribution # Value: # Returns a numeric vector "g(x)" for the generator computed at # the x values taken from the input vector. If x is missing, # the normalizing constant "lambda" will be returned. # FUNCTION: # Match Arguments: type = match.arg(type) # Handle Missing x: if (missing(x)) { x = NA output = "lambda" } else { output = "g" } # Get Type: type = type[1] # Get Parameters: # if (is.null(param)) param = ellipticalParam$param # Create Generator: if (type == "norm") { g = exp(-x/2) lambda = 1 / (2*pi) param = NULL } if (type == "cauchy") { g = ( 1 + x )^ (-3/2 ) lambda = 1 / (2*pi) param = NULL } if (type == "t") { if (is.null(param)) { nu = 4 } else { nu = param[[1]] } g = ( 1 + x/nu )^ ( -(nu+2)/2 ) lambda = 1/(2*pi) param = c(nu = nu) } if (type == "logistic"){ g = exp(-x/2)/(1+exp(-x/2))^2 # lambda: # integrate(function(x) { exp(-x)/(1+exp(-x))^2}, 0, Inf, # subdivision = 10000, rel.tol = .Machine$double.eps^0.8) # 0.5 with absolute error < 2.0e-13 lambda = 1 / pi param = NULL } if (type == "laplace") { # or "double exponential" # epower - with r = 1, s = 1 # g = exp(-r*(x/2)^s) # lambda = s * r^(1/s) / ( 2 * pi * gamma(1/s) ) g = exp(-sqrt(x)) lambda = 1/(2*pi) param = NULL } if (type == "kotz") { # epower - with s = 1 if (is.null(param)) { r = 1 } else { r = param } g = exp(-r*(x/2)) lambda = r/(2*pi) param = c(r = r) } if (type == "epower") { if (is.null(param)) { r = 1 s = 1 } else { r = param[[1]] s = param[[2]] } g = exp(-r*(x/2)^s) lambda = s * r^(1/s) / ( 2 * pi * gamma(1/s) ) param = c(r = r, s = s) } # Output: output = output[1] if (output == "g") { ans = g } else if (output == "lambda") { ans = lambda } # Add Control: if (output == "g") { attr(ans, "control") <- c(copula = "elliptical", type = type, lambda = as.character(lambda)) } else if (output == "lambda") { if (is.null(param)) { attr(ans, "control") <- unlist(list(copula = "elliptical", type = type)) } else { attr(ans, "control") <- unlist(list(copula = "elliptical", type = type, param = param)) } } # Return Value: ans } # ------------------------------------------------------------------------------ gfuncSlider <- function(B = 10) { # A function implemented by Diethelm Wuertz # Description: # Slider for generator function, density and probability # FUNCTION: # Graphic Frame: par(mfrow = c(2, 2), cex = 0.7) # Internal Function: refresh.code = function(...) { # Startup Counter: .counter <- setRmetricsOptions(".counter") + 1 setRmetricsOptions(.counter = .counter) if (.counter < 6) return () # Sliders: Copula = as.integer(.sliderMenu(no = 1)) type = ellipticalList() type = type[Copula] Type = c("Normal", "Cauchy", "Student-t", "Logistic", "Laplace", "Kotz", "Exponential Power") Type = Type[Copula] N = .sliderMenu(no = 2) nu = .sliderMenu(no = 3) r = .sliderMenu(no = 4) s = .sliderMenu(no = 5) rho = .sliderMenu(no = 6) L = 6.5 # Parameters: param = NULL if (Copula == 3) param = nu if (Copula == 6) param = r if (Copula == 7) param = c(r, s) prefactor = gfunc(param = param, type = type)[[1]] Lambda = as.character(round(prefactor, digits = 3)) Nu = R = S = NA if (Copula == 3) Nu = as.character(round(nu, digits = 1)) if (Copula >= 6) R = as.character(round(r, digits = 1)) if (Copula == 7) S = as.character(round(s, digits = 1)) delta = 10/N # Bivariate Density: x = y = seq(-4, 4, length = 101) D = delliptical2d(grid2d(x), rho = rho, param = param, type = type, output = "list") # Plot 1: Limit = "" if (Copula == 3 & nu == 1) Limit = "| [Cauchy]" if (Copula == 6 & r == 1) Limit = "| [Normal]" if (Copula == 7 & s == 1) Limit = "| [Kotz]" if (Copula == 7 & r == 1 & s == 1) Limit = "| [Normal]" lambda = gfunc(param = param, type = type) x = seq(0, L, length = N) y = gfunc(x, param = param, type = type) y.norm = gfunc(x, type = "norm") plot(x, y, type = "l", ylab = "g", ylim = c(0, 1)) abline(h = 0, lty = 3, col = "grey") lines(x, y.norm, lty = 3, col = "red") title(main = paste("Generator:", Type, Limit, "\nPre-Factor:", Lambda)) mtext("Dotted Curve: Normal Generator", side = 4, col = "grey", cex = 0.7) # Plot 2 - Density: x = seq(-L, L, length = N) y = .delliptical(x, param = param, type = type) y.norm = .delliptical(x, type = "norm") plot(x, y, type = "l", ylab = "Density", ylim = c(0, 0.65)) abline(h = 0, lty = 3, col = "grey") abline(v = 0, lty = 3, col = "grey") lines(x, y.norm, lty = 3, col = "red") Y = 2*integrate(.delliptical, 0, Inf, param = param, type = type)[[1]] Y = as.character(round(Y, 2)) .velliptical = function(x, param, type) x^2*.delliptical(x, param, type) V = 2*integrate(.delliptical, 0, Inf, param = param, type = type)[[1]] V = as.character(round(V, 2)) mtext(paste("Normalization Test:", Y, " | Variance Test:", V), side = 4, col = "grey", cex = 0.7) if (type == "t") { title(main = paste(Type, "Density\n nu =", Nu)) } else if (type == "kotz") { title(main = paste(Type, "Density\n r =", R)) } else if (type == "epower") { title(main = paste(Type, "Density\n r =", R, "s =", S)) } else { title(main = paste(Type, "Density\n ")) } # Plot 3 - Probability: x = seq(-L, L, length = N) y = .pelliptical(x, param = param, type = type) y.norm = .pelliptical(x, type = "norm") plot(x, y, type = "l", ylab = "Probability", ylim = c(0, 1)) abline(h = 0, lty = 3, col = "grey") abline(h = 1, lty = 3, col = "grey") abline(h = 0.5, lty = 3, col = "grey") lines(x, y.norm, lty = 3, col = "red") p95 = .qelliptical(0.95, param = param, type = type) P95 = as.character(round(p95, digits = 2)) abline(v = p95, lty = 3) abline(v = -p95, lty = 3) q95 = .pelliptical(p95, param = param, type = type) points(+p95, q95, pch = 19, cex = 0.5) points(-p95, 1-q95, pch = 19, cex = 0.5) mtext("Dots: Probability(Quantile(0.95)) Test", side = 4, col = "grey", cex = 0.7) Title = paste(Type, "Probability\n 95% =", P95) title(main = Title) # Plot 4 - Bivariate Density: contour(D, levels = c(0.001, 0.01, 0.025, 0.05, 0.1), xlab = "x", ylab = "y") title(main = paste("Bivariate Density\nrho = ", as.character(rho))) grid() # Reset Frame: par(mfrow = c(2, 2), cex = 0.7) } # Open Slider Menu: setRmetricsOptions(.counter = 0) .sliderMenu(refresh.code, names = c("Copula", "N", "3: nu", "6|7: r", "7: s", "rho"), minima = c( 1, 50, 1, 0.1, 0.1, -0.95), maxima = c( 7, 2000, B, B, B, 0.95), resolutions = c( 1, 50, 0.1, 0.1, 0.1, 0.05), starts = c( 1, 100, 4, 1, 1, 0.00)) } # ------------------------------------------------------------------------------ .pelliptical <- function(q, param = NULL, type = ellipticalList(), alternative = TRUE, subdivisions = 100) { # A function implemented by Diethelm Wuertz # Description: # Probability function for univariate elliptical distributions # Arguments: # q - a numeric vector # param - NULL, a numeric value, or a numeric vector adding. # additional parameters to the generator function. # type - a character string denoting the type of distribution. # This may be either # "norm" for the normal distribution, or # "cauchy" for the Cauchy distribution, or # "t" for the Student-t distribution, or # "logistic" for the logistic distribution, or # "laplace" for the distribution, or # "kotz" for the original Kotz distribution, or # "epower" for the exponential power distribution. # Details: # The probability is computed by integration using the generator # function. If an alternative faster algorithm is available, # this one is used by default. # FUNCTION: # Type: type = match.arg(type) # Alternative Available? if (type == "logistic") alternative = FALSE if (type == "laplace") alternative = FALSE if (type == "kotz") alternative = FALSE if (type == "epower") alternative = FALSE # Original Function: # Fq1 = function (x, Q, param, type) { # acos(abs(Q)/sqrt(x)) * gfunc(x, param, type) } # Transformed Function: u = exp(-x+Q^2) Fq2 = function (x, Q, param, type) { Q^2 * acos(sqrt(x))/x^2 * gfunc(Q^2/x, param, type) } # Add Default Parameters: if (is.null(param)) { if (type == "t") param = c(nu = 4) if (type == "kotz") param = c(r = 1) if (type == "epower") param = c(r = 1, s = 1) } # Probability: ans = NULL if (alternative) { ans = NA if (type[1] == "norm") ans = pnorm(q) if (type[1] == "cauchy") ans = pt(q, df = 1) # pcauchy(q) if (type[1] == "t") ans = pt(q, df = param[[1]]) if (type[1] == "kotz") ans = dnorm(q, sd = 1/sqrt(param[[1]])) } else { lambda = gfunc(param = param, type = type)[[1]] ans = NULL for ( Q in q ) { # More Precise Adaptive Rule: # p = lambda * integrate(Fq1, lower = Q^2, upper = Inf, Q = Q, # param = param, type = type, subdivisions = subdivisions)[[1]] p = lambda*integrate(Fq2, lower = .Machine$double.eps^0.5, upper = 1, Q = Q, param = param, type = type, stop.on.error = FALSE, subdivisions = subdivisions)[[1]] if (Q > 0) p = 1 - p if (abs(Q) < .Machine$double.eps^0.5) p = 0.5 ans = c(ans, p) } } # Return Value: ans } # ------------------------------------------------------------------------------ .delliptical <- function(x, param = NULL, type = ellipticalList(), alternative = TRUE, subdivisions = 100) { # A function implemented by Diethelm Wuertz # Description: # Density function for univariate elliptical distributions # Arguments: # x - a numeric vector # param - NULL, a numeric value, or a numeric vector adding. # additional parameters to the generator function. # type - a character string denoting the type of distribution. # This may be either # "norm" for the normal distribution, or # "cauchy" for the Cauchy distribution, or # "t" for the Student-t distribution, or # "logistic" for the logistic distribution, or # "laplace" for the distribution, or # "kotz" for the original Kotz distribution, or # "epower" for the exponential power distribution. # alternative - a logical flag. Should alternatively used a # faster algorithm if available? By default TRUE. # Details: # The density is computed by integration using the generator # function. If an alternative faster algorithm is available, # this one is used by default. # FUNCTION: # Type: type = match.arg(type) # Alternative Available? if (type == "logistic") alternative = FALSE if (type == "laplace") alternative = FALSE if (type == "kotz") alternative = FALSE if (type == "epower") alternative = FALSE # Original Function: # fq1 = function (x, Q, param, type) { # gfunc(x, param, type) / ( sqrt(x - Q^2) ) } # Transformed Function: log(x)^2 = x - Q^2 fq2 = function (x, Q, param, type) { 2 * gfunc(log(x)^2+Q^2, param, type) / x } # Add Default Parameters: if (is.null(param)) { if (type == "t") param = c(nu = 4) if (type == "kotz") param = c(r = 1) if (type == "epower") param = c(r = 1, s = 1) } # Normalizing constant lambda: lambda = gfunc(param = param, type = type)[[1]] # Density: ans = NULL if (alternative) { ans = NA if (type[1] == "norm") ans = dnorm(x) if (type[1] == "cauchy") ans = dt(x, df = 1) # dcauchy(x) if (type[1] == "t") ans = dt(x, df = param[[1]]) if (type[1] == "kotz") ans = dnorm(x, sd = 1/sqrt(param[[1]])) } else { lambda = gfunc(param = param, type = type)[[1]] ans = NULL for ( Q in x ) { # More Precise Adaptive Rule: # p = lambda*integrate(fq1, lower = Q^2, upper = Inf, Q = Q, # param = param, type = type)[[1]] p = lambda*integrate(fq2, lower = 0, upper = 1, Q = Q, param = param, type = type, stop.on.error = FALSE, subdivisions = subdivisions)[[1]] ans = c(ans, p) } } # Return Value: ans } # ------------------------------------------------------------------------------ .qelliptical <- function(p, param = NULL, type = ellipticalList(), alternative = TRUE) { # A function implemented by Diethelm Wuertz # Description: # Quantile function for univariate elliptical distributions # Arguments: # p - a numeric vector # param - NULL, a numeric value, or a numeric vector adding. # additional parameters to the generator function. # type - a character string denoting the type of distribution. # This may be either # "norm" for the normal distribution, or # "cauchy" for the Cauchy distribution, or # "t" for the Student-t distribution, or # "logistic" for the logistic distribution, or # "laplace" for the distribution, or # "kotz" for the original Kotz distribution, or # "epower" for the exponential power distribution. # alternative - a logical flag. Should be an alternative # faster algorithm used and not the standard algorithm? # Details: # The probability is computed by integration using the generator # function. If an alternative faster algorithm is available, # this one is used by default. # FUNCTION: # Type: type = match.arg(type) # Alternative Available? if (type == "laplace") alternative = FALSE if (type == "kotz") alternative = FALSE if (type == "epower") alternative = FALSE # Add Default Parameters: if (is.null(param)) { if (type == "t") param = c(nu = 4) if (type == "kotz") param = c(r = 1) if (type == "epower") param = c(r = 1, s = 1) } # Probability: ans = NULL if (alternative) { ans = NA if (type[1] == "norm") ans = qnorm(p) if (type[1] == "cauchy") ans = qcauchy(p) if (type[1] == "t") ans = qt(p, df = param[[1]]) if (type[1] == "logistic") ans = .qlogistic(p) if (type[1] == "kotz") ans = dnorm(p, sd = 1/sqrt(param[[1]])) } else { froot <- function(x, p, param, type) { .pelliptical(q = x, param = param, type = type) - p } ans = NULL for (pp in p) { if (pp < .Machine$double.eps) { ans = c(ans, -Inf) } else if (pp > 1 - .Machine$double.eps) { ans = c(ans, Inf) } else { lower = -1 upper = +1 counter = 0 iteration = NA while (is.na(iteration)) { iteration = .unirootNA(f = froot, interval = c(lower, upper), param = param, type = type, p = pp) counter = counter + 1 lower = lower - 2^counter upper = upper + 2^counter } ans = c(ans, iteration) } } } # Return Value: ans } # ------------------------------------------------------------------------------ .qlogistic <- function(p) { # A function implemented by Diethelm Wuertz # Description: # Fast Quantile function for the logistic distribution # FUNCTION: # Table: data = .qlogisticTable # Quantiles: P = (sign(p-1/2)+1)/2 - sign(p-1/2)*p ans = sign(0.5-p) * approx(x = data[, 2], y = data[, 1], xout = P)$y # p Boundary: index = which(p < 0.001 & p > 0) if (length(index) > 0) { ans[index] = .qelliptical(p[index], type = "logistic", alternative = FALSE) } index = which(p > 1-0.001 & p < 1) if (length(index) > 0) { ans[index] = .qelliptical(p[index], type = "logistic", alternative = FALSE) } ans[p == 0.5] = 0 ans[p == 0] = -Inf ans[p == 1] = Inf # Return Value: ans } # ------------------------------------------------------------------------------ .qlogisticData <- function (dump = FALSE ) { # A function implemented by Diethelm Wuertz # FUNCTION: # Range: p = seq(0.001, 0.500, by = 0.001) # Quantiles by Integration: froot = function(x, p) { .pelliptical(x, type = "logistic") - p } X = NULL for (P in p) { lower = -1 upper = +1 counter = 0 iteration = NA while (is.na(iteration)) { iteration = .unirootNA(f = froot, interval = c(lower, upper), p = P) counter = counter + 1 lower = lower - 2^counter upper = upper + 2^counter } X = c(X, iteration) } Y = .pelliptical(X, type = "logistic") .qlogisticTable = data.frame(cbind(X = X, Y = Y)) # Dump: if (dump) dump(".qlogisticTable", "qlogisticTable.R") # Return Value: invisible(.qlogisticTable) } # ------------------------------------------------------------------------------ .qlogisticTable <- structure(list( X = c( -3.28961095698868, -3.08838952917050, -2.96495324742154, -2.87441959067841, -2.80235793855428, -2.74216585623189, -2.69027685632636, -2.64454429353653, -2.60362855984489, -2.56644066721983, -2.53234562858188, -2.50082506289166, -2.47148229772502, -2.44400686160488, -2.41815107184679, -2.39371408491880, -2.37053072103299, -2.34846344243532, -2.32739647429067, -2.30723141378254, -2.28791218251300, -2.26930432832626, -2.25137887299253, -2.23407971956745, -2.21735785753918, -2.20116988800091, -2.18547719458243, -2.17024525936846, -2.15544310253510, -2.14104280951074, -2.12701913726668, -2.11334918152059, -2.1000120943421, -2.08698884326631, -2.07426200479765, -2.06181558657013, -2.04963487351506, -2.03770629424047, -2.02601730451810, -2.01455628530110, -2.00331245315227, -1.99227557959128, -1.98143672734491, -1.97078698069461, -1.96031819468915, -1.95002274531123, -1.93989348557452, -1.92992370611904, -1.92010709998667, -1.91043773071894, -1.90091000365456, -1.89151863995147, -1.88225865304357, -1.87312532726254, -1.86411419838938, -1.85522103592924, -1.84644182692950, -1.83777276118156, -1.82921021766652, -1.82074871277337, -1.81238487394136, -1.80411802330877, -1.79594515630526, -1.78786340687312, -1.77987003898311, -1.77196243800415, -1.76413810662673, -1.75639465334193, -1.74872978943490, -1.7412023575414, -1.73368818564377, -1.7262462929639, -1.71887474483312, -1.71157168326167, -1.70433532304102, -1.69716394791141, -1.69005590701564, -1.68300961157971, -1.67602353180290, -1.66909619394163, -1.66222617757269, -1.65541211302264, -1.64865267895148, -1.64194660007940, -1.63529264504669, -1.62868962439725, -1.62213638867753, -1.61563182664270, -1.60917486356300, -1.60276445962361, -1.59639952641875, -1.59007925325713, -1.58380261455573, -1.57756869582143, -1.57137660985193, -1.56522549889593, -1.55911452857102, -1.55304289016109, -1.54700979879211, -1.54101449249394, -1.53505623130807, -1.52915261112904, -1.52326458881694, -1.51741167285209, -1.5115931890518, -1.50580848264567, -1.50005691749585, -1.49433787536073, -1.48865075519602, -1.48299497249102, -1.47736995863785, -1.47177516036924, -1.46621003903524, -1.4606740702944, -1.4551667434371, -1.44968756093365, -1.4442360379646, -1.43881170197258, -1.43341409223487, -1.42804275945499, -1.42269726537273, -1.41737718239130, -1.41208209321679, -1.40681159053369, -1.40156527665306, -1.39634276321712, -1.39114367089538, -1.38596762909750, -1.38081427569799, -1.37568325677215, -1.37057422634254, -1.36548684613562, -1.36042078534799, -1.35537572042174, -1.35035133482848, -1.34534731886170, -1.34036336943694, -1.33539918989953, -1.33045448983943, -1.32552898491301, -1.32062239667119, -1.31573445239396, -1.31086488493075, -1.30601343254650, -1.30117983877317, -1.29636385226647, -1.29156522666752, -1.28678372046926, -1.28201909688745, -1.27727112373605, -1.27253957330672, -1.26782422225068, -1.26312485147296, -1.25844124601302, -1.25377319494646, -1.24912049128124, -1.24448293185896, -1.23986031725926, -1.23525245170728, -1.23065914298397, -1.22608020233923, -1.22151544440770, -1.21696225226631, -1.21242200176641, -1.20789558040343, -1.20338280567676, -1.19888349860929, -1.19439748365017, -1.18992458855333, -1.18546464439883, -1.18101748533607, -1.17658294861366, -1.17216087446918, -1.16775110605060, -1.16341452449662, -1.15902890823835, -1.15465514386589, -1.15029304960735, -1.14594255361642, -1.14160347928037, -1.13727568813146, -1.13295904407152, -1.12865341331407, -1.12435866432809, -1.12007466778373, -1.11580129649967, -1.11153842461814, -1.10728593065946, -1.10304369280653, -1.09881159197813, -1.09458951100203, -1.09037733457144, -1.08617494920272, -1.08198224319439, -1.07779910658730, -1.07362543112605, -1.06946111022151, -1.06528196623425, -1.06113353941502, -1.05699432071886, -1.05286419954172, -1.04874306739911, -1.04463081785862, -1.04058838163140, -1.0364935858852, -1.03240736512243, -1.02832962049820, -1.02426025492196, -1.02019917300514, -1.01614628101095, -1.01210148680617, -1.00806469981498, -1.00403583097456, -1.00001479269255, -0.995987692143912, -0.99198188126047, -0.987982882923126,-0.983990646036694,-0.980005119840238, -0.976026253905185,-0.972053998133449,-0.968088302755545,-0.964129118328723, -0.96023743089134, -0.956291121335992,-0.952351176345156,-0.948417547764324, -0.944491447079358,-0.940578633091236,-0.936672395329904,-0.932772667777382, -0.928879385227229,-0.924992483271505,-0.921111898287973,-0.917237567427541, -0.913369428601936,-0.909507420471605,-0.905651482433843,-0.901801554611138, -0.89795757783973, -0.894119493658381,-0.890287244297353,-0.886460772667583, -0.882640022350059,-0.878824937585387,-0.875015463263552,-0.871211544913856, -0.867413128695051,-0.863620161385636,-0.859832590374336,-0.856050363650754, -0.852273429796184,-0.848501737974597,-0.844735237923773,-0.840973879946612, -0.837217614902577,-0.833466394199305,-0.82972016978436, -0.825978894137128, -0.82224252026086, -0.81851100167485, -0.81478429240676, -0.81106234698506, -0.807345120431618,-0.803632568254409, -0.799924646440352, -0.796221311448274, -0.79252252020199, -0.788828230083503, -0.785138398926326, -0.781452985008911, -0.777771947048196,-0.774095244193254, -0.770422836019059, -0.766754682520353, -0.763090744605994,-0.759430982092061, -0.755775356696648, -0.752123830034272, -0.748476364110065,-0.744832921314231, -0.741193464432255, -0.737557956577102, -0.733926361277322,-0.730298642409806, -0.726674764210157, -0.723054691267668, -0.719438388520393,-0.715825821250292, -0.712216955078455, -0.708611755960407, -0.705010190181483,-0.701412224352282, -0.697817825404193, -0.69422696058499, -0.690639597454501,-0.687055703880342, -0.68347524803372, -0.679898198385306, -0.676324523701167,-0.672754193038763, -0.669187175743011, -0.665623441442406, -0.662062960045204,-0.658505701735664, -0.654951636970346, -0.651400736474472, -0.647852971238333,-0.644308312513762, -0.640766731810652, -0.637228200893533, -0.633692691778194,-0.630160176728364, -0.626630628252438, -0.623104019100251, -0.619580322259904,-0.616059510954638, -0.612541558639745, -0.60902643899954, -0.60551412594436, -0.602004593607625, -0.598497816342926, -0.594993768721168, -0.591492425527744,-0.587993761759759, -0.584497752623287, -0.581004373530672, -0.577513600097867,-0.574025408141805, -0.570539773677817, -0.567056672917079, -0.563576082264099,-0.560097978314237, -0.55662233785126, -0.553149137844933, -0.549678355448641,-0.546209967997043, -0.542743953003765, -0.539280288159113, -0.53581895132783, -0.532359920546873, -0.528903174023226, -0.525448690131743, -0.521996447413011,-0.518546424571258, -0.515098600472271, -0.511652954141354, -0.508209464761305,-0.504768111670429, -0.501328874360566, -0.497891732475152, -0.494456665807302,-0.491023654297919, -0.487592678033829, -0.484163717245933, -0.480736752307392,-0.477311763731828, -0.473888732171551, -0.470467638415803, -0.467048463389035,-0.463631188149193, -0.460215793886032, -0.45680226191945, -0.453390573697839,-0.449980710796464, -0.44657265491585, -0.443166387880198, -0.43976189163582, -0.436359148249581, -0.432958139907375, -0.429558848912609, -0.426161257684707,-0.422765348757635, -0.419371104778434, -0.415978508505784, -0.41258754280857, -0.409198190664474, -0.405810435158577, -0.402424259481984, -0.399039646930456,-0.395656580903062, -0.392275044900847, -0.388895022525509, -0.385516497478098,-0.382139453557724, -0.378763874660278, -0.375389744777172, -0.372017047994090,-0.368645768489747, -0.36527589053467, -0.361907398489987, -0.358540276806227,-0.355174510022136, -0.351810082763504, -0.348446979742001, -0.345085185754029,-0.341724685679586, -0.338365464481134, -0.335007507202486, -0.331650798967702,-0.328295324979995, -0.324941070520646, -0.321588020947929, -0.318236161696055,-0.314885478274112, -0.311535956265027, -0.308187581324529, -0.304840339180130,-0.301494152790354, -0.298149133027608, -0.294805203648722, -0.291462350657759,-0.28812056012555, -0.284779814605342, -0.281440107419829, -0.278101421295547,-0.274763742560770, -0.271427057605776, -0.268091352881914, -0.264756614900680,-0.261422830232804, -0.258089985507338, -0.254758067410761, -0.251427062686079,-0.248096958131943, -0.244767740601768, -0.241439397002857, -0.238111914295537,-0.234785279492298, -0.231459479656942, -0.228134501903726, -0.224810333396537,-0.221486961348039, -0.218164373018853, -0.214842555716734, -0.21152149679575, -0.208201183655463, -0.204881603740137, -0.201562744537922, -0.198244593580064,-0.194927138440111, -0.191610366733128, -0.188294266114916, -0.184978824281230,-0.181664028967013, -0.178349867945625, -0.175036329028080, -0.171723400062291,-0.168411068932309, -0.165099323557576, -0.161788151892181, -0.158477541924117,-0.15516748167454, -0.151857959197035, -0.148548962576890, -0.145240479930364,-0.141932499403962, -0.138625009173723, -0.135317997444490, -0.132011452449203,-0.128705362448187, -0.125399715728434, -0.122094500602899, -0.118789705409793,-0.115485318511868, -0.112181328295712, -0.108877723171037, -0.105574491569969, -0.102271621946344, -0.0989691027749957, -0.0956669225510829, -0.0923650697894468, -0.0890635330240574, -0.0857623008076265, -0.0824613617115197, -0.0791607043262014, -0.0758603172625963, -0.0725601891549516, -0.069260308666142, -0.0659606644967098, -0.0626612453993505, -0.0593620402006167, -0.0560630378306748, -0.0527642273584164, -0.0494655980205171, -0.0461671392155751, -0.0428688404062201, -0.0395706908379783, -0.0362726789608858, -0.0329747914456716, -0.0296770116896015, -0.0263793175678826, -0.0230816777192755, -0.0197840449696766, -0.0164872991738574, -0.0132014769537292, -0.0099153529555198, -0.00656807273015348,-0.00328316565264927, 0), Y = c(0.000999989790249075, 0.00199997659631066,0.0030000533744429, 0.00400032302535487, 0.00500028183011033,0.00600024440622486, 0.00700036400791461, 0.00800057651215374,0.00899926075702241, 0.00999936918645765, 0.0109994715833541,0.0119995614818643,0.0129996374478306,0.0139997002917028, 0.0149997517033347,0.0159997935471271,0.0169998275539801,0.0179998552300887, 0.0189998778128955,0.0199998963093886,0.0209984200243254,0.0219986195324741, 0.0229987985092580,0.0239989556602773,0.0249990929774641,0.0259992125331238, 0.0269993163154686,0.0279994063127642,0.028999484230876, 0.0299995516446606, 0.0309996099536415,0.0319996603894939,0.0329997040283535,0.033999741805388, 0.034999774530007, 0.0359998029007155,0.0369998275190071,0.0379998489022468, 0.0389998674948231,0.0399998836784007,0.0409998977807025,0.0419999100844623, 0.0429999208323128,0.0439999302262356,0.0449999384488791,0.0459999456542143, 0.0469999519731455,0.0479999575239014,0.0489999624033934,0.0499999666971179, 0.050999970479087, 0.0519999738134476,0.0529999767558638,0.0539999793547017, 0.0549999816520199,0.0559999836844612,0.0569999854839726,0.0579999870784435, 0.0589999884922518,0.0600002322660306,0.0610007382842464,0.0620012176556511, 0.0630016721028811,0.0640021032232844,0.0650025124989912,0.0660029014066227, 0.0670032710226466,0.0680036226385918,0.0690039573610388,0.0699961909442808, 0.0709964157890431,0.0719966272564782,0.0729968261635939,0.0739970132882051, 0.074997189351493, 0.075997355027219, 0.076997510945194, 0.0779976576944622, 0.0789977958262262,0.0799979258565364,0.0809980482687644,0.0819981635158824, 0.0829982720225615,0.0839983741871086,0.0849984703832535,0.0859985609618, 0.0869986462521522,0.0879987265637271,0.0889988021872626,0.0899988733960295, 0.0909989402880648,0.0919990034241728,0.0929990628713735,0.0939991188435381, 0.0949991716757273,0.0959992212888924,0.0969992679961586,0.0979993119655162, 0.0989993533551862,0.0999993923142102,0.100999428983003, 0.101996361340610, 0.102996667458178, 0.103996948294911, 0.104997205893694, 0.105997442136406, 0.106997658756622, 0.107997857350875, 0.108998039389096, 0.109998206224314, 0.110998359101641, 0.111998499159902, 0.112998627466711, 0.113998744983746, 0.114998852601866, 0.115998951139948, 0.116999041350541, 0.117999123925120, 0.118999199498883, 0.119999268655243, 0.120999331929934, 0.121999389814826, 0.122999442762193, 0.123999491184829, 0.124999535463806, 0.125999575947988, 0.126999612957384, 0.127999646785496, 0.12899967770146, 0.129999705952036, 0.13099973176343, 0.131999755342970, 0.132999776880658, 0.133999796550584, 0.134999814512239, 0.135999830911716, 0.136999845882814, 0.137999859548057, 0.138999872019624, 0.139999883400211, 0.140999893783817, 0.141999903256468, 0.142999911896882, 0.143999919777082, 0.144999926962952, 0.145999933514754, 0.146999939487602, 0.147999944931889, 0.148999949893692, 0.149999954415129, 0.150999958534699, 0.151999962287943, 0.152999965706274, 0.153999968819446, 0.154999971654293, 0.155999974235324, 0.156999976584922, 0.157999978723527, 0.158999980669799, 0.159999982440775, 0.160999984052003, 0.161999985517674, 0.163000522714305, 0.164001257335553, 0.165001955709628, 0.166002619635127, 0.167003250824463, 0.168003850907805, 0.169004421443053, 0.170004963894409, 0.171005479673739, 0.17200597011836, 0.173006436500641, 0.174006880031024, 0.174993398219765, 0.175993761862996, 0.176994106194154, 0.177994440428791, 0.178994740610310, 0.179995032746045, 0.180995309240802, 0.181995570901728, 0.182995818495872, 0.183996052752091, 0.184996274362880, 0.185996483986112, 0.186996682428530, 0.187996869918613, 0.188997047203267, 0.189997214817756, 0.190997373270305, 0.191997523043414, 0.192997664595105, 0.193997798360121, 0.194997924751063, 0.195998044159472, 0.196998156956866, 0.198004064106562, 0.199004781577514, 0.200005456363768, 0.201006090989097, 0.202006687834809, 0.203007249147298, 0.203992879823315, 0.204993345345794, 0.205993781542165, 0.20699419018612, 0.207994572949000, 0.208994931405369, 0.209995267038304, 0.210995581244424, 0.211995875338658, 0.212996150558767, 0.213996408069636, 0.215000093310879, 0.216000369275620, 0.217000821976959, 0.218001445611404, 0.219002234487624, 0.220003183024853, 0.221004285751305, 0.222005537302608, 0.223006932420246, 0.223992987554550, 0.22499462733946, 0.225996395713614, 0.226998287825741, 0.227999977350380, 0.228999972825903, 0.229999967831223, 0.230999962364020, 0.231999956424305, 0.232999950014237, 0.233999943137955, 0.234999935801416, 0.235999928012238, 0.236999919779558, 0.237999911113890, 0.238999902026997, 0.23999989253177, 0.240999882642106, 0.241999872372804, 0.242999861739457, 0.243999850758354, 0.244999839446394, 0.245999827820992, 0.246999815900002, 0.247999803701641, 0.248999791244413, 0.249999778547048, 0.250999765628433, 0.251999752507560, 0.252999739203466, 0.253999725735183, 0.254999712121693, 0.255999698381881, 0.256999684534495, 0.257999670598112, 0.258999656591096, 0.259999642531572, 0.260999628437393, 0.261999614326116, 0.262999600214975, 0.263999586120861, 0.264999572060296, 0.265999558049426, 0.266999544103992, 0.267999530239325, 0.268999516470329, 0.269999502811470, 0.270999489276768, 0.271999475879788, 0.272999462633633, 0.273999449550939, 0.274999436643870, 0.275999423928137, 0.276999411406967, 0.277999399095057, 0.278999387002665, 0.279999375139568, 0.280999363515069, 0.281999352133693, 0.282999341012350, 0.283999330154682, 0.284999319568118, 0.285999309259627, 0.286999299235725, 0.287999289502482, 0.288999280065525, 0.289999270930049, 0.290999262100821, 0.291999253582187, 0.292999245378082, 0.293999237492035, 0.294999229927180, 0.295999222686262, 0.296999215771647, 0.297999209185332, 0.298999202928950, 0.299999197003782, 0.300999191410765, 0.301999186150503, 0.302999181223271, 0.303999176629033, 0.304999172367443, 0.305999168437859, 0.306999164839350, 0.307999161570707, 0.308999158630451, 0.309999156016846, 0.3109991537279, 0.311999151761384, 0.312999150114833, 0.313999148785561, 0.314999147770665, 0.315999147067038, 0.316999146671377, 0.317999146580187, 0.318999146789796, 0.319999147296359, 0.320999148095870, 0.321999149184165, 0.322999150556936, 0.323999152209734, 0.324999154137979, 0.325999156336969, 0.326999158801883, 0.327999161527793, 0.328999164509669, 0.329999167742386, 0.330999171220733, 0.331999174939416, 0.332999178893067, 0.333999183076251, 0.334999187483469, 0.335999192109171, 0.336999196947752, 0.337999201993567, 0.338999207240932, 0.33999921268413, 0.340999218317417, 0.341999224135028, 0.342999230131179, 0.343999236300076, 0.344999242635916, 0.345999249132897, 0.346999255785214, 0.347999262587073, 0.348999269532686, 0.349999276616284, 0.350999283832112, 0.351999291174441, 0.352999298637566, 0.353999306215812, 0.354999313903537, 0.355999321695133, 0.356999329585035, 0.357999337567717, 0.3589993456377, 0.359999353789552, 0.360999362017892, 0.361999370317391, 0.362999378682777, 0.363999387108836, 0.364999395590413, 0.365999404122415, 0.366999412699814, 0.367999421317649, 0.368999429971024, 0.369999438655116, 0.37099944736517, 0.371999456096506, 0.372999464844517, 0.373999473604672, 0.374999482372517, 0.375999491143676, 0.376999499913850, 0.377999508678821, 0.378999517434455, 0.379999526176695, 0.380999534901569, 0.381999543605189, 0.382999552283749, 0.383999560933529, 0.384999569550893, 0.38599957813229, 0.386999586674258, 0.387999595173416, 0.388999603626474, 0.389999612030226, 0.390999620381554, 0.391999628677426, 0.392999636914899, 0.393999645091113, 0.394999653203298, 0.395999661248771, 0.396999669224934, 0.397999677129276, 0.398999684959373, 0.399999692712886, 0.400999700387563, 0.401999707981236, 0.402999715491823, 0.403999722917325, 0.40499973025583, 0.405999737505508, 0.406999744664612, 0.407999751731479, 0.408999757699432, 0.409999764564645, 0.410999771332861, 0.411999778002731, 0.412999784572988, 0.413999792115251, 0.414999798496769, 0.415999804775648, 0.416999810950938, 0.417999817021771, 0.41899982298735, 0.419999828846956, 0.420999834599940, 0.421999840245729, 0.422999845783821, 0.423999851213786, 0.424999856535265, 0.425999861747966, 0.42699986685167, 0.427999871846223, 0.428999876731538, 0.429999881507595, 0.43099988617444, 0.431999890732181, 0.432999895180991, 0.433999899521106, 0.434999903752824, 0.435999907876499, 0.436999911892552, 0.437999915801457, 0.438999919603749, 0.439999923300017, 0.440999926890908, 0.441999930377125, 0.442999933759421, 0.443999937038606, 0.444999940215541, 0.445999943291138, 0.446999946266358, 0.447999949142211, 0.448999951919758, 0.449999954600106, 0.450999957184407, 0.45199995967386, 0.452999962069707, 0.453999964373235, 0.454999966585772, 0.455999968708689, 0.456999970743396, 0.457999972691344, 0.458999974554023, 0.45999997633296, 0.460999978029718, 0.461999979645896, 0.462999981183131, 0.46399998264309, 0.464999984027476, 0.465999985338022, 0.466999986576494, 0.467999987744687, 0.468999988844425, 0.469999989877562, 0.470999990845976, 0.471999991751573, 0.472999992596279, 0.473999993382044, 0.474999994110834, 0.47599999478463, 0.476999995405422, 0.477999995975202, 0.478999996495962, 0.479999996969683, 0.480999997398343, 0.481999997783931, 0.48299999812849, 0.483999998434203, 0.484999998703553, 0.485999998939509, 0.486999999145696, 0.487999999326349, 0.488999999485856, 0.489999999628004, 0.490999999755448, 0.49199999986999, 0.492999999973083, 0.494000000064158, 0.494999711104453, 0.495996057848887, 0.496992418350526, 0.49800732088262, 0.499003719695633, 0.499999999819624)), .Names = c("X", "Y"), row.names = c("1", "2", "3", "4", "5", "6", "7", "8", "9", "10", "11", "12", "13", "14", "15", "16", "17", "18", "19", "20", "21", "22", "23", "24", "25", "26", "27", "28", "29", "30", "31", "32", "33", "34", "35", "36", "37", "38", "39", "40", "41", "42", "43", "44", "45", "46", "47", "48", "49", "50", "51", "52", "53", "54", "55", "56", "57", "58", "59", "60", "61", "62", "63", "64", "65", "66", "67", "68", "69", "70", "71", "72", "73", "74", "75", "76", "77", "78", "79", "80", "81", "82", "83", "84", "85", "86", "87", "88", "89", "90", "91", "92", "93", "94", "95", "96", "97", "98", "99", "100", "101", "102", "103", "104", "105", "106", "107", "108", "109", "110", "111", "112", "113", "114", "115", "116", "117", "118", "119", "120", "121", "122", "123", "124", "125", "126", "127", "128", "129", "130", "131", "132", "133", "134", "135", "136", "137", "138", "139", "140", "141", "142", "143", "144", "145", "146", "147", "148", "149", "150", "151", "152", "153", "154", "155", "156", "157", "158", "159", "160", "161", "162", "163", "164", "165", "166", "167", "168", "169", "170", "171", "172", "173", "174", "175", "176", "177", "178", "179", "180", "181", "182", "183", "184", "185", "186", "187", "188", "189", "190", "191", "192", "193", "194", "195", "196", "197", "198", "199", "200", "201", "202", "203", "204", "205", "206", "207", "208", "209", "210", "211", "212", "213", "214", "215", "216", "217", "218", "219", "220", "221", "222", "223", "224", "225", "226", "227", "228", "229", "230", "231", "232", "233", "234", "235", "236", "237", "238", "239", "240", "241", "242", "243", "244", "245", "246", "247", "248", "249", "250", "251", "252", "253", "254", "255", "256", "257", "258", "259", "260", "261", "262", "263", "264", "265", "266", "267", "268", "269", "270", "271", "272", "273", "274", "275", "276", "277", "278", "279", "280", "281", "282", "283", "284", "285", "286", "287", "288", "289", "290", "291", "292", "293", "294", "295", "296", "297", "298", "299", "300", "301", "302", "303", "304", "305", "306", "307", "308", "309", "310", "311", "312", "313", "314", "315", "316", "317", "318", "319", "320", "321", "322", "323", "324", "325", "326", "327", "328", "329", "330", "331", "332", "333", "334", "335", "336", "337", "338", "339", "340", "341", "342", "343", "344", "345", "346", "347", "348", "349", "350", "351", "352", "353", "354", "355", "356", "357", "358", "359", "360", "361", "362", "363", "364", "365", "366", "367", "368", "369", "370", "371", "372", "373", "374", "375", "376", "377", "378", "379", "380", "381", "382", "383", "384", "385", "386", "387", "388", "389", "390", "391", "392", "393", "394", "395", "396", "397", "398", "399", "400", "401", "402", "403", "404", "405", "406", "407", "408", "409", "410", "411", "412", "413", "414", "415", "416", "417", "418", "419", "420", "421", "422", "423", "424", "425", "426", "427", "428", "429", "430", "431", "432", "433", "434", "435", "436", "437", "438", "439", "440", "441", "442", "443", "444", "445", "446", "447", "448", "449", "450", "451", "452", "453", "454", "455", "456", "457", "458", "459", "460", "461", "462", "463", "464", "465", "466", "467", "468", "469", "470", "471", "472", "473", "474", "475", "476", "477", "478", "479", "480", "481", "482", "483", "484", "485", "486", "487", "488", "489", "490", "491", "492", "493", "494", "495", "496", "497", "498", "499", "500"), class = "data.frame" ) ################################################################################ fCopulae/R/zzz.R0000644000176000001440000000331112406047540013221 0ustar ripleyusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA ############################################################################### .onAttach <- function(libname, pkgname) { # do whatever needs to be done when the package is loaded # some people use it to bombard users with # messages using packageStartupMessage( "\n" ) packageStartupMessage( "Rmetrics Package fCopulae" ) packageStartupMessage( "Modeling Copulae" ) packageStartupMessage( "Copyright (C) 2005-2014 Rmetrics Association Zurich" ) packageStartupMessage( "Educational Software for Financial Engineering and Computational Science" ) packageStartupMessage( "Rmetrics is free software and comes with ABSOLUTELY NO WARRANTY." ) packageStartupMessage( "https://www.rmetrics.org --- Mail to: info@rmetrics.org" ) } ############################################################################### .onLoad <- function(libname, pkgname) { timeDate::setRmetricsOptions(.counter = NA) } ################################################################################ fCopulae/R/EmpiricalCopulae.R0000644000176000001440000001262512406047540015612 0ustar ripleyusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA ################################################################################ # FUNCTION: EMPIRICAL COPULAE PROBABILIY: # pempiricalCopula Computes empirical copula probability # FUNCTION: EMPIRICAL COPULAE DENSITY: # dempiricalCopula Computes empirical copula density # FUNCTION: DEBYE FUNCTION: # .Debye Returns the value of the Debye function of order k # .Debye1 Returns the value of the Debye function of order 1 # FUNCTION: # .pmoCopula # .dmoCopula ################################################################################ ################################################################################ # FUNCTION: EMPIRICAL COPULAE PROBABILIY: # pempiricalCopula Computes empirical copula probability pempiricalCopula <- function(u, v, N = 10) { # A function implemented by Diethelm Wuertz # Description # Computes the empirical copula probability # Source: # bouye02a.pdf # FUNCTION: # Settings: if (is.list(u)) { v = u[[2]] u = u[[1]] } if (is.matrix(u)) { v = u[, 1] u = u[, 2] } # Probability: p = q = (0:N)/N h = matrix(rep(0, times = (N+1)^2), N+1) for ( i in (0:N) ) { for ( j in (0:N) ) { z = Heaviside(u, p[i+1]) + Heaviside(v, q[j+1]) h[j+1, i+1] = length(z[z == 0]) } } h = h/length(u) # Return Value: list(x = p, y = q, z = h) } ################################################################################ # FUNCTION: EMPIRICAL COPULAE DENSITY: # dempiricalCopula Computes empirical copula density dempiricalCopula <- function(u, v, N = 10) { # A function implemented by Diethelm Wuertz # Description # Computes the empirical copula probability # Source: # bouye02a.pdf # FUNCTION: # Settings: if (is.list(u)) { v = u[[2]] u = u[[1]] } if (is.matrix(u)) { v = u[, 1] u = u[, 2] } # Probability: ans = pempiricalCopula(u, v, N) X = ans$x Y = ans$y C = ans$z # Density: M = N+1 x = X[-1] - diff(X)/2 y = Y[-1] - diff(Y)/2 c = C[-1,-1]+C[-M,-M]-C[-1,-M]-C[-M,-1] # Return Value: list(x = x, y = y, z = c) } ################################################################################ # FUNCTION: DEBYE FUNCTION: # .Debye Returns the value of the Debye function of order k # .Debye1 .Debye <- function(x, k = 1) { # A function implemented by Diethelm Wuertz # Description: # Returns the value of the Debye function of order k # Arguments: # x - a numeric value or vector # k - the order of the Debye function, a positive integer value # FUNCTION: # Check: if (!is.integer(k) | k <= 0) stop("k must be a positive integer") # Loop: D = NULL error = NULL for ( i in 1:length(x) ) { nextD = .Debye1(x[i],k) D = c(D, nextD[[1]]) error = c(error, nextD[[2]]) } # Add error attribute: attr(D, "error") = error # Return Value: D } # ------------------------------------------------------------------------------ .Debye1 <- function(x, k = 1) { # A function implemented by Diethelm Wuertz # FUNCTION: # Function to be integrated: d = function(x, lambda) { x^lambda / ( exp(x) - 1 ) } # Integrate: u = abs(x) if (x == 0) { D = 1 error = 0 } else { ans = integrate(f = d, lower = 0, upper = u, lambda = k) D = k * ans[[1]] / u^k error = ans[[2]] } if (x < 0) { D = D + k*u/(k+1) } # Return Value: list(D = D, error = error) } ################################################################################ # FUNCTION: # .pmoCopula # .dmoCopula .pmoCopula <- function(u = 0.5, v = u, alpha = NULL) { if (is.null(alpha)) alpha = c(0.5, 0.5) alpha1 = alpha[1] alpha2 = alpha[2] U = u^(1-alpha1) * v V = u * v^(1-alpha2) UV = cbind(U,V) apply(UV, 1, max) } # ------------------------------------------------------------------------------ .dmoCopula <- function(u = 0.5, v = u, alpha = NULL) { if (is.null(alpha)) alpha = c(0.5, 0.5) alpha1 = alpha[1] alpha2 = alpha[2] U = u^(1-alpha1) * v V = u * v^(1-alpha2) UV = cbind(U,V) apply(UV, 1, max) } ################################################################################ fCopulae/MD50000644000176000001440000001005512406311445012351 0ustar ripleyusers069404d67832a534f33ba999e3b2d142 *ChangeLog 03492ced902f14db115a52196d30c095 *DESCRIPTION d613da28e0b50ed8237e6700194b5460 *NAMESPACE b224c94b7b4cadb927e4bb7f10fb39d3 *R/ArchimedeanCopulae.R 2ecff1b4ef03dca8bd390416e70d7728 *R/ArchimedeanDependency.R cb195a3002bdeaf47dcf8213e0086f58 *R/ArchimedeanGenerator.R df46e935e2e8fe9c0b8389a11398c745 *R/ArchimedeanModelling.R d1448727aeb5c2bfb70ea051f3d29b14 *R/ArchimedeanSlider.R d2708cbe8df88efac4bb1ef8196d369f *R/EllipticalCopulae.R d648d61dfc570f419e48ea47a03779aa *R/EllipticalDependency.R 4fa6db2ede6ff3999d42506461aa6c11 *R/EllipticalGenerator.R ff1b598b5b38c986cb9ae589348bca3c *R/EllipticalModelling.R 83b5f567bddea6a012c6b1dfd5778843 *R/EmpiricalCopulae.R 645ca0158a158f51982d750fa11fb3d0 *R/ExtremeValueCopulae.R fd6d1f817a41bfea6b205c75000999ba *R/ExtremeValueDependency.R 88172d828a93cbf37f4782ab1d9e7078 *R/ExtremeValueGenerator.R dccbc5d81da8cecb6c2d24a43a0488f0 *R/ExtremeValueModelling.R 24b6e829324e611e40b53f598f99020e *R/aaaCopulaeClass.R cc66b4093da5eaf07f5692f598fed2a3 *R/aaaCopulaeEnv.R 143cc3c7c7d4c9ccbb6c3e4ceb30ed76 *R/zzz.R 28904ec67ad108b7d933bed2d9602b65 *inst/obsolete/R/biv-binning.R 33ebc9f0c61e57bf206752e2ab08a84d *inst/obsolete/R/biv-density.R bf80eda2207641e1486de2649263b1cb *inst/obsolete/R/biv-gridding.R fc4cd13b043e75b73ab522de6f8a54c3 *inst/obsolete/R/builtin-adapt.R fc65d1675df34e46e66a4588990ee940 *inst/obsolete/R/bv-dcauchy.R dc89d7904bfd40ff3c1ef5c0fa96b2c0 *inst/obsolete/R/bv-delliptical.R c0ae6dd505d87ba282fc4415ae929df6 *inst/obsolete/R/bv-dnorm.R 0b956cf8e243e6b48402b9db69f034fe *inst/obsolete/R/bv-dt.R 6728cc8658694dfd46b671e3e4c8c27b *inst/obsolete/R/mv-distributions.R 4c3f51acecd49217a4fe9d51392f3bf4 *inst/obsolete/R/mv-dsnorm.R e6fe483c6db38c6eba55b045fa52df39 *inst/obsolete/R/mv-dst.R 0ae32d48faf982f676ee2721b1ea4e02 *inst/obsolete/src/adapt2.f bf0cc4d5a94a7545fdb9d6dcd73306af *inst/obsolete/src/adapt_callback.c bbb359058801e2c11c6fe242deadbbf0 *inst/unitTests/Makefile b3dfb205136831d39e558c232cdb025a *inst/unitTests/runTests.R 7b2fb68b07b1bcb3031af0bbaae9401d *inst/unitTests/runit.ArchimedeanCopulae.R c621d826877c3bfa872a49a1065d47f1 *inst/unitTests/runit.ArchimedeanDependency.R c88b95efbb2d4bc75b1ebd9df8aeb8a3 *inst/unitTests/runit.ArchimedeanGenerator.R d38397d2fc0dc6eb89002fefaf079088 *inst/unitTests/runit.ArchimedeanModelling.R 8ceae4c74d1cb701634a4cf7a1eaea3d *inst/unitTests/runit.EllipticalCopulae.R dcedc8a4dd5069a1d7688659a649e145 *inst/unitTests/runit.EllipticalDependency.R 42d75060cf879d166823264a80794fe2 *inst/unitTests/runit.EllipticalGenerator.R 92f244d8f50bb1beaafca75103c77938 *inst/unitTests/runit.EllipticalModelling.R 2ec7439e6cca7f30bb1ee18b4d55102d *inst/unitTests/runit.EmpiricalCopulae.R 5438f55742a20e12ad93e2cd03ca794e *inst/unitTests/runit.ExtremeValueCopulae.R a6345f50524edc1f8b467a0bc554ee84 *inst/unitTests/runit.ExtremeValueDependency.R 9a51f166fa789c12d60982413ab8dd4a *inst/unitTests/runit.ExtremeValueModelling.R df81a4997de286f18c9b699b90f462a3 *inst/unitTests/runit.ExtrmeValueGenerator.R c812d9fca2be1e1ae085f282b1d291c1 *inst/unitTests/runit.aaaCopulaClass.R b6c70ab404057c7d41615ab1827d57f8 *man/00fCopulae-package.Rd 90072dc7563f14dcea9fd5efa62d06f1 *man/ArchimedeanCopulae.Rd 0ed0a793f6c4f19edffd48e634de74f2 *man/ArchimedeanDependency.Rd 34e50b7a0e7f34c599ec2455c0b1ea1b *man/ArchimedeanGenerator.Rd 24e3120bde46175dd44cec2bec363f13 *man/ArchimedeanModelling.Rd d3f26dc082ab56570acfc56440cb9977 *man/EllipticalCopulae.Rd 3c880bfdb1a891eaa25ebc3274b0c48f *man/EllipticalDependency.Rd b161fed0d027b34779f64e1f3ee2d074 *man/EllipticalGenerator.Rd 160fddf4faf3ea6c218d01c28a5b6107 *man/EllipticalModelling.Rd ab3c21c844982a45425329cbc5a72c36 *man/EmpiricalCopulae.Rd 4b34f841d13c4014f42ab07789fc8492 *man/ExtremeValueCopulae.Rd 39ba0f048a8c1fac7e8116e7227cf101 *man/ExtremeValueDependency.Rd 041c895cf8dd9f181fb9ff7b4ed15875 *man/ExtremeValueGenerator.Rd 2f6c7b7aa20fb72e73764713a3e2d3b7 *man/ExtremeValueModelling.Rd f90fde38f6c413e80f56f77fa13d065d *man/aaaCopulaClass.Rd 36e22401a240adfdad1ebea7a571e1f3 *man/aaaCopulaEnv.Rd ca566e590ec30abd0718c5375e1a446f *tests/doRUnit.R fCopulae/DESCRIPTION0000644000176000001440000000150412406311445013546 0ustar ripleyusersPackage: fCopulae Title: Rmetrics - Bivariate Dependence Structures with Copulae Date: 2013-03-18 Version: 3011.81 Author: Rmetrics Core Team, Diethelm Wuertz [aut], Tobias Setz [cre] Yohan Chalabi [ctb] Maintainer: Tobias Setz Description: Environment for teaching "Financial Engineering and Computational Finance". Depends: R (>= 2.15.1), timeDate, timeSeries, fBasics, fMultivar Suggests: methods, RUnit, tcltk, mvtnorm, sn Note: SEVERAL PARTS ARE STILL PRELIMINARY AND MAY BE CHANGED IN THE FUTURE. THIS TYPICALLY INCLUDES FUNCTION AND ARGUMENT NAMES, AS WELL AS DEFAULTS FOR ARGUMENTS AND RETURN VALUES. LazyData: yes License: GPL (>= 2) URL: https://www.rmetrics.org Packaged: 2014-09-16 14:55:28 UTC; Tobi NeedsCompilation: no Repository: CRAN Date/Publication: 2014-09-17 15:56:52 fCopulae/ChangeLog0000644000176000001440000000414212406047540013615 0ustar ripleyusers ChangeLog Package fCopulae 2014-09-16 setz * ChangeLog, DESCRIPTION: Updated ChangeLog and DESCRIPTION files after submission to CRAN * NAMESPACE: Updated NAMESPACE; functions with a dot in front are no longer exported. * R/ArchimedianSlider.R: Removed duplicated functions * src and depending R functions moved to inst/obsolete/ 2014-02-03 wuertz * mvtnorm and sn are now loaded as Depends from fMultivar 2013-03-15 chalabi * DESCRIPTION: Updated maintainer field and version number * R/zzz.R: Removed depcrecated .First.lib() * R/bv-dnorm.R: Removed trailing whitespaces 2011-09-23 mmaechler * DESCRIPTION: remove deprecated "LazyLoad" entry 2010-10-26 chalabi * NAMESPACE: updated NAMESPACE 2010-07-23 chalabi * inst/DocCopying.pdf: removed DocCopying.pdf license is already specified in DESCRIPTION file 2009-10-27 chalabi * ChangeLog, DESCRIPTION: updated Changelog and DESCRIPTION file * DESCRIPTION, src/adapt_callback.c: added declaration of FORTRAN routine in C before use 2009-10-16 chalabi * NAMESPACE: updated NAMESPACE 2009-10-16 wuertz * DESCRIPTION, R/builtin-adapt.R, man/builtin-adapt.Rd, src, src/adapt2.f, src/adapt_callback.c: adapt added 2009-09-28 chalabi * DESCRIPTION: updated version number * ChangeLog, DESCRIPTION: updated DESCR and ChangeLog * NAMESPACE: new NAMESPACE structure which should ease maintenance of packages. 2009-06-25 chalabi * DESCRIPTION: Merge branch 'devel-timeSeries' Conflicts: pkg/timeSeries/R/base-Extract.R pkg/timeSeries/R/timeSeries.R 2009-04-19 chalabi * DESCRIPTION: added explicit version number in Depends field for key packages 2009-04-02 chalabi * DESCRIPTION: more explicit depends and suggests field in DESC file. * NAMESPACE: updated NAMESPACE * DESCRIPTION: updated DESC file 2009-01-28 chalabi * man/ArchimedeanCopulae.Rd, man/ArchimedeanDependency.Rd, man/ArchimedeanModelling.Rd, man/EmpiricalCopulae.Rd, man/ExtremeValueCopulae.Rd, man/ExtremeValueDependency.Rd, man/ExtremeValueGenerator.Rd, man/ExtremeValueModelling.Rd: updated manual pages to new Rd parser fCopulae/man/0000755000176000001440000000000012406047540012615 5ustar ripleyusersfCopulae/man/EllipticalDependency.Rd0000644000176000001440000001436712406047540017200 0ustar ripleyusers\name{EllipticalDependency} \alias{EllipticalDependency} \alias{ellipticalTau} \alias{ellipticalRho} \alias{ellipticalTailCoeff} \alias{ellipticalTailPlot} \title{Bivariate Elliptical Copulae} \description{ A collection and description of functions to investigate bivariate elliptical copulae. \cr Elliptical Copulae Functions: \tabular{ll}{ \code{ellipticalTau} \tab Computes Kendall's tau for elliptical copulae, \cr \code{ellipticalRho} \tab computes Spearman's rho for elliptical copulae, \cr \code{ellipticalTailCoeff} \tab computes tail dependence for elliptical copulae, \cr \code{ellipticalTailPlot} \tab plots tail dependence for elliptical copulae. } } \usage{ ellipticalTau(rho) ellipticalRho(rho, param = NULL, type = ellipticalList(), subdivisions = 500) ellipticalTailCoeff(rho, param = NULL, type = c("norm", "cauchy", "t")) ellipticalTailPlot(param = NULL, type = c("norm", "cauchy", "t"), tail = c("Lower", "Upper")) } \arguments{ \item{rho}{ [*ellipticalCopula] - \cr is the numeric value setting the correlation strength, ranging between minus one and one. } \item{param}{ [*ellipticalCopula][gfunc] - \cr additional distributional parameters: for the Sudent-t distribution this is "nu", for the Kotz distribution this is "r", and for the Exponential Power distribution these are "r" and "s". If the argument \code{param=NULL} then default values are taken. These are for the Student-t \code{param=c(nu=4))}, for the Kotz distribution \code{param=c(r=1))}, and for the exponential power distribution \code{param=c(r=1,s=1)}. Note, that the Kotz and exponential power copulae are independent of \code{r}, and that \code{r} only enters the generator, the density, the probability and the quantile functions. } \item{subdivisions}{ [ellipticalRho] - \cr an integer value with the number of subdivisons in each direction on the two dimensional unit square to compute the mean value of Spearman's Rho. By default 500 subdivisions are used. } \item{tail}{ [ellipticalTailPlot] - \cr a character string, either \code{"Upper"} or \code{"Lower"} denoting which of the two tails should be displayed. By default the upper tail dependence will be considered. } \item{type}{ [*ellipticalCopula][gfunc] - \cr the type of the elliptical copula. A character string selected from: "norm", "cauchy", "t", "logistic", "laplace", "kotz", or "epower". [*ellipticalSlider] - \cr a character string which indicates what kind of plot should be displayed, either a perspective plot if \code{type="persp"}, the default value, or a contour plot if \code{type="contour"}. } \item{\dots}{ [ellipticalCopulaFit] - \cr arguments passed to the optimization function \code{nlminb}. } } \value{ \bold{Copula Functions:} \cr\cr The functions \code{[rpd]ellipticalCopula} return a numeric vector of random variates, probabilities, or densities for the specified copula computed at grid coordinates \code{u}|\code{v}. \cr The functions \code{[rpd]ellipticalSlider} display an interactive graph of an perspective copula plot either for random variates, probabilities or densities. Alternatively, an image underlayed contour plot can be shown. \cr \bold{Copula Dependence Measures:} \cr\cr The functions \code{ellipticalTau} and \code{ellipticalRho} return a numericc value for Kendall's Tau and Spearman's Rho. \cr \bold{Copula Tail Coefficient:} \cr\cr The function \code{ellipticalTailCoeff} returns the coefficient of tail dependence for a specified copula. The function \code{ellipticalTailPlot} displays a whole plot for the upper or alternatively for the lower tail dependence as a function of \code{u} for a set of nine \code{rho} values. \cr \bold{Copula Generator Function:} \cr\cr The function \code{gfunc} computes the generator function for the specified copula, by default the normal copula. If the argument \code{x} is missing, then the normalization constand lambda will be returned, otherwise if \code{x} is specified the values for the function \emph{g(x)} will be freturned. The selected type of copula is added to the output as an attribute named \code{"control"}. The function \code{gfuncSlider} allows to display interactively the generator function, the marginal density, the marginal probability, and the contours of the the bivariate density. \cr \bold{Copula Simulation and Parameter Fitting:} \cr\cr The function \code{ellipticalCopulaSim} returns a numeric two-column matrix with randomly generated variates for the specified copula. \cr The function \code{ellipticalCopulaFit} returns a fit to empirical data for the specified copula. The returned object is a list with elements from the function \code{nlminb}. } \author{ Diethelm Wuertz for the Rmetrics \R-port. } \examples{ ## [rp]ellipticalCopula - # Default Normal Copula: rellipticalCopula(10) pellipticalCopula(10) ## [rp]ellipticalCopula - # Student-t Copula Probability and Density: u = grid2d(x = (0:25)/25) pellipticalCopula(u, rho = 0.75, param = 4, type = "t", output = "list") d <- dellipticalCopula(u, rho = 0.75, param = 4, type = "t", output = "list") persp(d, theta = -40, phi = 30, col = "steelblue") ## ellipticalTau - ## ellipticalRho - # Dependence Measures: ellipticalTau(rho = -0.5) ellipticalRho(rho = 0.75, type = "logistic", subdivisions = 100) ## ellipticalTailCoeff - # Student-t Tail Coefficient: ellipticalTailCoeff(rho = 0.25, param = 3, type = "t") ## gfunc - # Generator Function: plot(gfunc(x = 0:10), main = "Generator Function") ## ellipticalCopulaSim - ## ellipticalCopulaSim - # Simualtion and Parameter Fitting: rv <- ellipticalCopulaSim(n = 100, rho = 0.75) ellipticalCopulaFit(rv) } \keyword{models} fCopulae/man/EllipticalGenerator.Rd0000644000176000001440000001300612406047540017035 0ustar ripleyusers\name{EllipticalGenerator} \alias{EllipticalGenerator} \alias{ellipticalList} \alias{ellipticalParam} \alias{ellipticalRange} \alias{ellipticalCheck} \alias{gfunc} \alias{gfuncSlider} \title{Bivariate Elliptical Copulae} \description{ A collection and description of functions concerned with the generator function for the elliptical copula and with functions for setting and checking the distributional parameters. \cr Functions: \tabular{ll}{ \code{ellipticalList} \tab Returns list of implemented elliptical copulae, \cr \code{ellipticalParam} \tab Sets default parameters for an elliptical copula, \cr \code{ellipticalRange} \tab returns the range of valid rho values, \cr \code{ellipticalCheck} \tab checks if rho is in the valid range, \cr \code{gfunc} \tab Generator function for elliptical distributions, \cr \code{gfuncSlider} \tab Slider for generator, density and probability. } } \usage{ ellipticalList() ellipticalParam(type = ellipticalList()) ellipticalRange(type = ellipticalList()) ellipticalCheck(rho = 0.75, param = NULL, type = ellipticalList()) gfunc(x, param = NULL, type = ellipticalList()) gfuncSlider(B = 10) } \arguments{ \item{B}{ [*Slider] - \cr the maximum slider menu value when the boundary value is infinite. By default this is set to 10. } \item{rho}{ [*ellipticalCopula] - \cr is the numeric value setting the correlation strength, ranging between minus one and one. } \item{param}{ [*ellipticalCopula][gfunc] - \cr additional distributional parameters: for the Sudent-t distribution this is "nu", for the Kotz distribution this is "r", and for the Exponential Power distribution these are "r" and "s". If the argument \code{param=NULL} then default values are taken. These are for the Student-t \code{param=c(nu=4))}, for the Kotz distribution \code{param=c(r=1))}, and for the exponential power distribution \code{param=c(r=1,s=1)}. Note, that the Kotz and exponential power copulae are independent of \code{r}, and that \code{r} only enters the generator, the density, the probability and the quantile functions. } \item{type}{ [*ellipticalCopula][gfunc] - \cr the type of the elliptical copula. A character string selected from: "norm", "cauchy", "t", "logistic", "laplace", "kotz", or "epower". [*ellipticalSlider] - \cr a character string which indicates what kind of plot should be displayed, either a perspective plot if \code{type="persp"}, the default value, or a contour plot if \code{type="contour"}. } \item{x}{ [gfunc] - \cr a numeric value or vector out of the range \code{[0,Inf)} at which the generator will be computed. } \item{\dots}{ [ellipticalCopulaFit] - \cr arguments passed to the optimization function \code{nlminb}. } } \value{ \bold{Copula Functions:} \cr\cr The functions \code{[rpd]ellipticalCopula} return a numeric vector of random variates, probabilities, or densities for the specified copula computed at grid coordinates \code{u}|\code{v}. \cr The functions \code{[rpd]ellipticalSlider} display an interactive graph of an perspective copula plot either for random variates, probabilities or densities. Alternatively, an image underlayed contour plot can be shown. \cr \bold{Copula Dependence Measures:} \cr\cr The functions \code{ellipticalTau} and \code{ellipticalRho} return a numericc value for Kendall's Tau and Spearman's Rho. \cr \bold{Copula Tail Coefficient:} \cr\cr The function \code{ellipticalTailCoeff} returns the coefficient of tail dependence for a specified copula. The function \code{ellipticalTailPlot} displays a whole plot for the upper or alternatively for the lower tail dependence as a function of \code{u} for a set of nine \code{rho} values. \cr \bold{Copula Generator Function:} \cr\cr The function \code{gfunc} computes the generator function for the specified copula, by default the normal copula. If the argument \code{x} is missing, then the normalization constand lambda will be returned, otherwise if \code{x} is specified the values for the function \emph{g(x)} will be freturned. The selected type of copula is added to the output as an attribute named \code{"control"}. The function \code{gfuncSlider} allows to display interactively the generator function, the marginal density, the marginal probability, and the contours of the the bivariate density. \cr \bold{Copula Simulation and Parameter Fitting:} \cr\cr The function \code{ellipticalCopulaSim} returns a numeric two-column matrix with randomly generated variates for the specified copula. \cr The function \code{ellipticalCopulaFit} returns a fit to empirical data for the specified copula. The returned object is a list with elements from the function \code{nlminb}. } \author{ Diethelm Wuertz for the Rmetrics \R-port. } \examples{ ## ellipticalList - # List implemented copulae: ellipticalList() ## gfunc - # Generator Function: gfunc(x <- (0:10)/10, param = 2, type = "t") ## gfuncSlider - # Try: \dontrun{ gfuncSlider()} } \keyword{models} fCopulae/man/ArchimedeanModelling.Rd0000644000176000001440000000506412406047540017144 0ustar ripleyusers\name{ArchimedeanModelling} \alias{ArchimedeanModelling} \alias{archmCopulaSim} \alias{archmCopulaFit} \title{Bivariate Archimedean Copulae} \description{ A collection and description of functions to investigate bivariate Archimedean copulae. \cr Archimedean Copulae Functions: \tabular{ll}{ \code{archmCopulaSim} \tab simulates an Archimedean copula, \cr \code{archmCopulaFit} \tab fits the parameters of an Archimedean copula. } } \usage{ archmCopulaSim(n, alpha = NULL, type = archmList()) archmCopulaFit(u, v = NULL, type = archmList(), \dots) } \arguments{ \item{alpha}{ [Phi*][*archmCopula] - \cr the parameter of the Archemedean copula. A numerical value. } \item{n}{ [rarchmCopula] - \cr the number of random deviates to be generated, an integer value. } \item{type}{ the type of the Archimedean copula. A character string ranging beween \code{"1"} and \code{"22"}. By default copula No. 1 will be chosen. } \item{u, v}{ [*archmCopula] - \cr two numeric values or vectors of the same length at which the copula will be computed. If \code{u} is a list then the the \code{\$x} and \code{\$y} elements will be used as \code{u} and \code{v}. If \code{u} is a two column matrix then the first column will be used as \code{u} and the the second as \code{v}. } \item{\dots}{ [archmCopulaFit] - \cr arguments passed to the optimization function in use, \code{nlminb}. } } \value{ The function \code{pcopula} returns a numeric matrix of probabilities computed at grid positions \code{x}|\code{y}. \cr The function \code{parchmCopula} returns a numeric matrix with values computed for the Archemedean copula. \cr The function \code{darchmCopula} returns a numeric matrix with values computed for thedensity of the Archemedean copula. \cr The functions \code{Phi*} return a numeric vector with the values computed from the Archemedean generator, its derivatives, or its inverse. \cr The functions \code{cK} and \code{cKInv} return a numeric vector with the values of the density and inverse for Archimedian copulae. } \author{ Diethelm Wuertz for the Rmetrics \R-port. } % \examples{ % ## fCOPULA - % # getClass("fCOPULA") % ## pcopula - % # The default Normal Copula: % # contour(pcopula()) % } \keyword{models} fCopulae/man/aaaCopulaEnv.Rd0000644000176000001440000000035112406047540015442 0ustar ripleyusers\name{CopulaEnv} \alias{CopulaEnv} \title{Bivariate Copula Environment} \description{ Set and Get functions for the Copula environment. } %\usage{} %\arguments{} %\value{} %\examples{} \keyword{models} fCopulae/man/EllipticalModelling.Rd0000644000176000001440000001425512406047540017030 0ustar ripleyusers\name{EllipticalModelling} \alias{EllipticalModelling} \alias{ellipticalCopulaSim} \alias{ellipticalCopulaFit} \title{Bivariate Elliptical Copulae} \description{ A collection and description of functions to investigate bivariate elliptical copulae. \cr Elliptical Copulae Functions: \tabular{ll}{ \code{ellipticalCopulaSim} \tab simulates an elliptical copula, \cr \code{ellipticalCopulaFit} \tab fits the parameters of an elliptical copula. } } \usage{ ellipticalCopulaSim(n, rho = 0.75, param = NULL, type = c("norm", "cauchy", "t")) ellipticalCopulaFit(u, v, type = c("norm", "cauchy", "t"), \dots) } \arguments{ \item{n}{ [rellipticalCopula][ellipticalCopulaSim] - \cr the number of random deviates to be generated, an integer value. } \item{rho}{ [*ellipticalCopula] - \cr is the numeric value setting the correlation strength, ranging between minus one and one. } \item{param}{ [*ellipticalCopula][gfunc] - \cr additional distributional parameters: for the Sudent-t distribution this is "nu", for the Kotz distribution this is "r", and for the Exponential Power distribution these are "r" and "s". If the argument \code{param=NULL} then default values are taken. These are for the Student-t \code{param=c(nu=4))}, for the Kotz distribution \code{param=c(r=1))}, and for the exponential power distribution \code{param=c(r=1,s=1)}. Note, that the Kotz and exponential power copulae are independent of \code{r}, and that \code{r} only enters the generator, the density, the probability and the quantile functions. } \item{type}{ [*ellipticalCopula][gfunc] - \cr the type of the elliptical copula. A character string selected from: "norm", "cauchy", "t", "logistic", "laplace", "kotz", or "epower". [*ellipticalSlider] - \cr a character string which indicates what kind of plot should be displayed, either a perspective plot if \code{type="persp"}, the default value, or a contour plot if \code{type="contour"}. } \item{u, v}{ [*ellipticalCopula] - \cr two numeric values or vectors of the same length at which the copula will be computed. If \code{u} is a list then the the \code{\$x} and \code{\$y} elements will be used as \code{u} and \code{v}. If \code{u} is a two column matrix then the first column will be used as \code{u} and the the second as \code{v}. If \code{u} is an integer value greater than one, say \code{N}, than the values for all points on the \code{[(0:N)/N]^2} grid spanning the unit square will be returned. } \item{\dots}{ [ellipticalCopulaFit] - \cr arguments passed to the optimization function \code{nlminb}. } } \value{ \bold{Copula Functions:} \cr\cr The functions \code{[rpd]ellipticalCopula} return a numeric vector of random variates, probabilities, or densities for the specified copula computed at grid coordinates \code{u}|\code{v}. \cr The functions \code{[rpd]ellipticalSlider} display an interactive graph of an perspective copula plot either for random variates, probabilities or densities. Alternatively, an image underlayed contour plot can be shown. \cr \bold{Copula Dependence Measures:} \cr\cr The functions \code{ellipticalTau} and \code{ellipticalRho} return a numericc value for Kendall's Tau and Spearman's Rho. \cr \bold{Copula Tail Coefficient:} \cr\cr The function \code{ellipticalTailCoeff} returns the coefficient of tail dependence for a specified copula. The function \code{ellipticalTailPlot} displays a whole plot for the upper or alternatively for the lower tail dependence as a function of \code{u} for a set of nine \code{rho} values. \cr \bold{Copula Generator Function:} \cr\cr The function \code{gfunc} computes the generator function for the specified copula, by default the normal copula. If the argument \code{x} is missing, then the normalization constand lambda will be returned, otherwise if \code{x} is specified the values for the function \emph{g(x)} will be freturned. The selected type of copula is added to the output as an attribute named \code{"control"}. The function \code{gfuncSlider} allows to display interactively the generator function, the marginal density, the marginal probability, and the contours of the the bivariate density. \cr \bold{Copula Simulation and Parameter Fitting:} \cr\cr The function \code{ellipticalCopulaSim} returns a numeric two-column matrix with randomly generated variates for the specified copula. \cr The function \code{ellipticalCopulaFit} returns a fit to empirical data for the specified copula. The returned object is a list with elements from the function \code{nlminb}. } \author{ Diethelm Wuertz for the Rmetrics \R-port. } \examples{ ## [rp]ellipticalCopula - # Default Normal Copula: rellipticalCopula(10) pellipticalCopula(10) ## [rp]ellipticalCopula - # Student-t Copula Probability and Density: u = grid2d(x = (0:25)/25) # CHECK ERROR # pellipticalCopula(u, rho = 0.75, param = 4, # type = "t", output = "list") # CHECK ERROR DONE d = dellipticalCopula(u, rho = 0.75, param = 4, type = "t", output = "list") persp(d, theta = -40, phi = 30, col = "steelblue") ## ellipticalTau - ## ellipticalRho - # Dependence Measures: ellipticalTau(rho = -0.5) ellipticalRho(rho = 0.75, type = "logistic", subdivisions = 100) ## ellipticalTailCoeff - # Student-t Tail Coefficient: ellipticalTailCoeff(rho = 0.25, param = 3, type = "t") ## gfunc - # Generator Function: plot(gfunc(x = 0:10), main = "Generator Function") ## ellipticalCopulaSim - ## ellipticalCopulaSim - # Simualtion and Parameter Fitting: rv <- ellipticalCopulaSim(n = 100, rho = 0.75) ellipticalCopulaFit(rv) } \keyword{models} fCopulae/man/ExtremeValueDependency.Rd0000644000176000001440000000710012406047540017507 0ustar ripleyusers\name{ExtremeValueDependency} \alias{ExtremeValueDependency} \alias{evTau} \alias{evRho} \alias{evTailCoeff} \alias{evTailCoeffSlider} \title{Bivariate Extreme Value Copulae} \description{ A collection and description of functions to investigate bivariate extreme value copulae. \cr Extreme Value Copulae Functions: \tabular{ll}{ \code{evTau} \tab Computes Kendall's tau for extreme value copulae, \cr \code{evRho} \tab computes Spearman's rho for extreme value copulae, \cr \code{evTailCoeff} \tab computes tail dependence for extreme value copulae, \cr \code{evTailCoeffSlider} \tab plots tail dependence for extreme value copulae. } } \usage{ evTau(param = NULL, type = evList(), alternative = FALSE) evRho(param = NULL, type = evList(), alternative = FALSE) evTailCoeff(param = NULL, type = evList()) evTailCoeffSlider(B = 10) } \arguments{ \item{alternative}{ [evRho][evTau][*evCopula] - \cr Should the probability be computed alternatively in a direct way from the probability formula or by default via the dependency function? } \item{B}{ [*Slider] - \cr the maximum slider menu value when the boundary value is infinite. By default this is set to 10. } %\item{error}{ % [evRho] - \cr % the error bound to be achieved by the \code{integrate2d} % integration formula. A numeric value, by default \code{error=1.0e-5}. % } \item{param}{ [*ev*][A*] - \cr distribution and copulae parameters. A numeric value or vector of named parameters as required by the copula specified by the variable \code{type}. If set to \code{NULL}, then the default parameters will be taken. } \item{type}{ [*ev*][Afunc] - \cr the type of the extreme value copula. A character string selected from: "gumbel", "galambos", "husler.reiss", "tawn", or "bb5". \cr [evSlider] - \cr a character string specifying the plot type. Either a perspective plot which is the default or a contour plot with an underlying image plot will be created. } \item{\dots}{ [evCopulaFit] - \cr arguments passed to the optimization function \code{nlminb}. } } \value{ The function \code{pcopula} returns a numeric matrix of probabilities computed at grid positions \code{x}|\code{y}. \cr The function \code{parchmCopula} returns a numeric matrix with values computed for the Archemedean copula. \cr The function \code{darchmCopula} returns a numeric matrix with values computed for thedensity of the Archemedean copula. \cr The functions \code{Phi*} return a numeric vector with the values computed from the Archemedean generator, its derivatives, or its inverse. \cr The functions \code{cK} and \code{cKInv} return a numeric vector with the values of the density and inverse for Archimedian copulae. } \author{ Diethelm Wuertz for the Rmetrics \R-port. } \examples{ ## fCOPULA - getClass("fCOPULA") getSlots("fCOPULA") ## revCopula - # Not yet implemented # revCopula(n = 10, type = "galambos") ## pevCopula - pevCopula(u = grid2d(), type = "galambos", output = "list") ## devCopula - devCopula(u = grid2d(), type = "galambos", output = "list") ## AfuncSlider - # Generator, try: \dontrun{AfuncSlider()} } \keyword{models} fCopulae/man/ArchimedeanGenerator.Rd0000644000176000001440000000650012406047540017154 0ustar ripleyusers\name{ArchimedeanGenerator} \alias{ArchimedeanGenerator} \alias{archmList} \alias{archmParam} \alias{archmRange} \alias{archmCheck} \alias{Phi} \alias{PhiSlider} \alias{Kfunc} \alias{KfuncSlider} \title{Bivariate Archimedean Copulae} \description{ A collection and description of functions concerned with the generator function for the Archimedean copula and with functions for setting and checking the distributional parameters. \cr Functions: \tabular{ll}{ \code{evList} \tab Returns list of implemented Archimedean copulae, \cr \code{archmParam} \tab Sets default parameters for an Archimedean copula, \cr \code{archmRange} \tab returns the range of valid rho values, \cr \code{archmCheck} \tab checks if rho is in the valid range, \cr \code{Phi} \tab Computes generator Phi, inverse and derivatives, \cr \code{PhiSlider} \tab displays interactively generator function, \cr \code{Kfunc} \tab computes copula density and its inverse, \cr \code{KfuncSlider} \tab displays interactively density function. } } \usage{ archmList() archmParam(type = archmList()) archmRange(type = archmList(), B = Inf) archmCheck(alpha, type = archmList()) Phi(x, alpha = NULL, type = archmList(), inv = FALSE, deriv = paste(0:2)) PhiSlider(B = 5) Kfunc(x, alpha = NULL, type = archmList(), inv = FALSE, lower = 1.0e-8) KfuncSlider(B = 5) } \arguments{ \item{alpha}{ [Phi*][*archmCopula] - \cr the parameter of the Archemedean copula. A numerical value. } \item{B}{ [archmRange] - \cr the maximum slider menu value when the boundary value is infinite. By default this is set to \code{B=Inf}.\cr [*Slider] - \cr the maximum slider menu value when the boundary value is infinite. By default this is set to \code{B=5}. } \item{deriv}{ [Phi] - \cr an integer value. Should the function itself, \code{deriv="0"}, or the first \code{deriv="1"}, or second \code{deriv="2"} derivative be evaluated? } \item{inv}{ [Phi][Kfunc] - \cr a logical flag. Should the inverse function be computed? } \item{lower}{ [Kfunc] - \cr a numeric value setting the lower bound for the internal root finding function \code{uniroot}. } \item{type}{ [*archmCopula][Phi][Kfunc] - \cr the type of the Archimedean copula. A character string ranging beween \code{"1"} and \code{"22"}. By default copula No. 1 will be chosen. } \item{x}{ [Kfunc] - \cr a numeric value or vector ranging between zero and one.\cr [Phi] - \cr a numeric value or vector. } } \value{ The function \code{Phi} returns a numeric vector with the values computed from the Archemedean generator, its derivatives, or its inverse. \cr The function \code{Kfunc} returns a numeric vector with the values of the density and inverse for Archimedian copulae. } \author{ Diethelm Wuertz for the Rmetrics \R-port. } \references{ RB Nelson - An Introduction to Copulas } \examples{ ## archmList - # Return list of implemented copulae: archmList() } \keyword{models} fCopulae/man/ExtremeValueCopulae.Rd0000644000176000001440000001200712406047540017023 0ustar ripleyusers\name{ExtremeValueCopulae} \alias{ExtremeValueCopulae} \alias{revCopula} \alias{pevCopula} \alias{devCopula} \alias{revSlider} \alias{pevSlider} \alias{devSlider} \title{Bivariate Extreme Value Copulae} \description{ A collection and description of functions to investigate bivariate extreme value copulae. \cr Extreme Value Copulae Functions: \tabular{ll}{ \code{revCopula} \tab Generates extreme value copula random variates, \cr \code{pevCopula} \tab computes extreme value copula probability, \cr \code{devCopula} \tab computes extreme value copula density, \cr \code{revSlider} \tab displays interactive plots of extreme value random variates, \cr \code{pevSlider} \tab displays interactive plots of extreme value probability, \cr \code{devSlider} \tab displays interactive plots of extreme value density. } } \usage{ revCopula(n, param = NULL, type = evList()) pevCopula(u = 0.5, v = u, param = NULL, type = evList(), output = c("vector", "list"), alternative = FALSE ) devCopula(u = 0.5, v = u, param = NULL, type = evList(), output = c("vector", "list"), alternative = FALSE ) revSlider(B = 10) pevSlider(type = c("persp", "contour"), B = 10) devSlider(type = c("persp", "contour"), B = 10) } \arguments{ \item{alternative}{ [evRho][evTau][*evCopula] - \cr Should the probability be computed alternatively in a direct way from the probability formula or by default via the dependency function? } \item{B}{ [*Slider] - \cr the maximum slider menu value when the boundary value is infinite. By default this is set to 10. } %\item{error}{ % [evRho] - \cr % the error bound to be achieved by the \code{integrate2d} % integration formula. A numeric value, by default \code{error=1.0e-5}. % } \item{n}{ [revCopula][evCopulaSim] - \cr the number of random deviates to be generated, an integer value. } \item{output}{ [*evCopula] - \cr output - a character string specifying how the output should be formatted. By default a vector of the same length as \code{u} and \code{v}. If specified as \code{"list"} then \code{u} and \code{v} are expected to span a two-dimensional grid as outputted by the function \code{grid2d} and the function returns a list with elements \code{$x}, \code{y}, and \code{z} which can be directly used for example by 2D plotting functions. } \item{param}{ [*ev*][A*] - \cr distribution and copulae parameters. A numeric value or vector of named parameters as required by the copula specified by the variable \code{type}. If set to \code{NULL}, then the default parameters will be taken. } \item{type}{ [*ev*][Afunc] - \cr the type of the extreme value copula. A character string selected from: "gumbel", "galambos", "husler.reiss", "tawn", or "bb5". \cr [evSlider] - \cr a character string specifying the plot type. Either a perspective plot which is the default or a contour plot with an underlying image plot will be created. } \item{u, v}{ [*evCopula][*archmCopula] - \cr two numeric values or vectors of the same length at which the copula will be computed. If \code{u} is a list then the the \code{$x} and \code{$y} elements will be used as \code{u} and \code{v}. If \code{u} is a two column matrix then the first column will be used as \code{u} and the the second as \code{v}. } \item{\dots}{ [evCopulaFit] - \cr arguments passed to the optimization function \code{nlminb}. } } \value{ The function \code{pcopula} returns a numeric matrix of probabilities computed at grid positions \code{x}|\code{y}. \cr The function \code{parchmCopula} returns a numeric matrix with values computed for the Archemedean copula. \cr The function \code{darchmCopula} returns a numeric matrix with values computed for thedensity of the Archemedean copula. \cr The functions \code{Phi*} return a numeric vector with the values computed from the Archemedean generator, its derivatives, or its inverse. \cr The functions \code{cK} and \code{cKInv} return a numeric vector with the values of the density and inverse for Archimedian copulae. } \author{ Diethelm Wuertz for the Rmetrics \R-port. } \examples{ ## fCOPULA - getClass("fCOPULA") getSlots("fCOPULA") ## revCopula - # Not yet implemented # revCopula(n = 10, type = "galambos") ## pevCopula - pevCopula(u = grid2d(), type = "galambos", output = "list") ## devCopula - devCopula(u = grid2d(), type = "galambos", output = "list") ## AfuncSlider - # Generator, try: \dontrun{AfuncSlider()} } \keyword{models} fCopulae/man/ExtremeValueGenerator.Rd0000644000176000001440000000545212406047540017367 0ustar ripleyusers\name{ExtremeValueGenerator} \alias{ExtremeValueGenerator} \alias{evList} \alias{evParam} \alias{evRange} \alias{evCheck} \alias{Afunc} \alias{AfuncSlider} \title{Bivariate Extreme Value Copulae} \description{ A collection and description of functions concerned with the generator function for the extreme value copula and with functions for setting and checking the distributional parameters. \cr Functions: \tabular{ll}{ \code{evList} \tab Returns list of implemented extreme value copulae, \cr \code{evParam} \tab sets default parameters for an extreme value copula, \cr \code{evRange} \tab returns the range of valid rho values, \cr \code{evCheck} \tab checks if rho is in the valid range, \cr \code{Afunc} \tab computes dependence function, \cr \code{AfuncSlider} \tab displays interactively dependence function. } } \usage{ evList() evParam(type = evList()) evRange(type = evList()) evCheck(param, type = evList()) Afunc(x, param = NULL, type = evList()) AfuncSlider() } \arguments{ \item{param}{ distribution and copulae parameters. A numeric value or vector of named parameters as required by the copula specified by the variable \code{type}. If set to \code{NULL}, then the default parameters will be taken. } \item{type}{ the type of the extreme value copula. A character string selected from: "gumbel", "galambos", "husler.reiss", "tawn", or "bb5". } \item{x}{ a numeric value or vector ranging between zero and one. } } \value{ The function \code{pcopula} returns a numeric matrix of probabilities computed at grid positions \code{x}|\code{y}. \cr The function \code{parchmCopula} returns a numeric matrix with values computed for the Archemedean copula. \cr The function \code{darchmCopula} returns a numeric matrix with values computed for thedensity of the Archemedean copula. \cr The functions \code{Phi*} return a numeric vector with the values computed from the Archemedean generator, its derivatives, or its inverse. \cr The functions \code{cK} and \code{cKInv} return a numeric vector with the values of the density and inverse for Archimedian copulae. } \author{ Diethelm Wuertz for the Rmetrics \R-port. } \examples{ ## fCOPULA - getClass("fCOPULA") getSlots("fCOPULA") ## revCopula - # Not yet implemented # revCopula(n = 10, type = "galambos") ## pevCopula - pevCopula(u = grid2d(), type = "galambos", output = "list") ## devCopula - devCopula(u = grid2d(), type = "galambos", output = "list") ## AfuncSlider - # Generator, try: \dontrun{AfuncSlider()} } \keyword{models} fCopulae/man/aaaCopulaClass.Rd0000644000176000001440000000726312406047540015770 0ustar ripleyusers\name{CopulaClass} \alias{CopulaClass} \alias{fCOPULA} \alias{fCOPULA-class} \alias{show,fCOPULA-method} \alias{pfrechetCopula} \title{Bivariate Copula Class} \description{ A collection and description of functions to specify the copula class and to investigate bivariate Frechet copulae. \cr The class representation and methods are: \tabular{ll}{ \code{fCOPULA} \tab representation for an S4 object of class "fCOPULA", \cr \code{show} \tab S4 print method. } Frechet Copulae: \tabular{ll}{ \code{pfrechetCopula} \tab computes Frechet copula probability. } } \usage{ \S4method{show}{fCOPULA}(object) pfrechetCopula(u = 0.5, v = u, type = c("m", "pi", "w"), output = c("vector", "list")) } \arguments{ \item{object}{ [show] - \cr an S4 object of class \code{"fCOPULA"}. } \item{output}{ [*frechetCopula] - \cr output - a character string specifying how the output should be formatted. By default a vector of the same length as \code{u} and \code{v}. If specified as \code{"list"} then \code{u} and \code{v} are expected to span a two-dimensional grid as outputted by the function \code{grid2d} and the function returns a list with elements \code{$x}, \code{y}, and \code{z} which can be directly used for example by 2D plotting functions. } \item{type}{ [*frechetCopula] - \cr the type of the Frechet copula. A character string selected from: \code{"m"}, \code{"pi"}, or \code{"w"}. } \item{u, v}{ two numeric values or vectors of the same length at which the copula will be computed. If \code{u} is a list then the the \code{$x} and \code{$y} elements will be used as \code{u} and \code{v}. If \code{u} is a two column matrix then the first column will be used as \code{u} and the the second as \code{v}. } } \value{ The print method \code{show} returns an S4 object of class \code{"fCOPULA"}. The object contains the following slots: \item{@call}{ the function call. } \item{@copula}{ the name of the copula. } \item{@param}{ a list whose elements specify the model parameters of the copula. } \item{@title}{ a character string with the name of the copula. This can be overwritten specifying a user defined input argument. } \item{@description}{ a character string with an optional user defined description. By default just the current date will be returned. } The function \code{pfrechetCopula} returns a numeric vector of probabilities. An attribute named \code{"control"} is added which returns the name of the Frechet copula. } \details{ The function \code{pfrechetCopula} returns a numeric matrix of probabilities computed at grid positions \code{u}|\code{v}. The arguments \code{u} and \code{v} are two single values or two numeric vectors of the same length. If \code{v} is not specified then the same values are taken as for \code{u}. Alternatively, \code{u} may be given as a two column vector or as a list with two entries as vectors. The first column or entry is taken as \code{u} and the second as \code{v}. } \author{ Diethelm Wuertz for the Rmetrics \R-port. } \examples{ ## fCOPULA - getClass("fCOPULA") ## pfrechet - # The Frechet Copula - m: pfrechetCopula(0.5) pfrechetCopula(0.25, 0.75) pfrechetCopula(runif(5)) ## grid2d - grid2d() pfrechetCopula(grid2d()) } \keyword{models} fCopulae/man/ArchimedeanCopulae.Rd0000644000176000001440000001113512406047540016616 0ustar ripleyusers\name{ArchimedeanCopulae} \alias{ArchimedeanCopulae} \alias{rarchmCopula} \alias{parchmCopula} \alias{darchmCopula} \alias{rarchmSlider} \alias{parchmSlider} \alias{darchmSlider} \alias{rgumbelCopula} \alias{pgumbelCopula} \alias{dgumbelCopula} \title{Bivariate Archimedean Copulae} \description{ A collection and description of functions to investigate bivariate Archimedean copulae. \cr Archimedean Copulae Functions: \tabular{ll}{ \code{rarchmCopula} \tab Generates Archimedean copula variates, \cr \code{parchmCopula} \tab computes Archimedean copula probability, \cr \code{darchmCopula} \tab computes Archimedean copula density, \cr \code{rarchmSlider} \tab displays interactive plots of variates, \cr \code{parchmSlider} \tab displays interactive plots of probability, \cr \code{darchmSlider} \tab displays interactive plots of density. } Special Copulae Functions: \tabular{ll}{ \code{rgumbelCopula} \tab Generates Gumbel copula variates, \cr \code{pgumbelCopula} \tab computes Gumbel copula probability, \cr \code{dgumbelCopula} \tab computes Gumbel copula density. } } \usage{ rarchmCopula(n, alpha = NULL, type = archmList()) parchmCopula(u = 0.5, v = u, alpha = NULL, type = archmList(), output = c("vector", "list"), alternative = FALSE ) darchmCopula(u = 0.5, v = u, alpha = NULL, type = archmList(), output = c("vector", "list"), alternative = FALSE ) rarchmSlider(B = 10) parchmSlider(type = c("persp", "contour"), B = 10) darchmSlider(type = c("persp", "contour"), B = 10) rgumbelCopula(n, alpha = 2) pgumbelCopula(u = 0.5, v = u, alpha = 2, output = c("vector", "list")) dgumbelCopula(u = 0.5, v = u, alpha = 2, output = c("vector", "list")) } \arguments{ \item{alpha}{ [Phi*][*archmCopula] - \cr the parameter of the Archemedean copula. A numerical value. } \item{alternative}{ [*Copula] - \cr Should the probability be computed alternatively ... } \item{B}{ [*Slider] - \cr the maximum slider menu value when the boundary value is infinite. By default this is set to 10. } \item{n}{ [rarchmCopula] - \cr the number of random deviates to be generated, an integer value. } \item{output}{ [*archmCopula] - \cr output - a character string specifying how the output should be formatted. By default a vector of the same length as \code{u} and \code{v}. If specified as \code{"list"} then \code{u} and \code{v} are expected to span a two-dimensional grid as outputted by the function \code{grid2d} and the function returns a list with elements \code{\$x}, \code{\$y}, and \code{\$z} which can be directly used for example by 2D plotting functions. } \item{type}{ [*archmCopula] - \cr the type of the Archimedean copula. A character string ranging beween \code{"1"} and \code{"22"}. By default copula No. 1 will be chosen.\cr [*archmSlider] - \cr the type of the plot. A charcter string either specifying a perspective or contour plot. } \item{u, v}{ [*archmCopula] - \cr two numeric values or vectors of the same length at which the copula will be computed. If \code{u} is a list then the the \code{\$x} and \code{\$y} elements will be used as \code{u} and \code{v}. If \code{u} is a two column matrix then the first column will be used as \code{u} and the the second as \code{v}. } } \value{ The function \code{pcopula} returns a numeric matrix of probabilities computed at grid positions \code{x}|\code{y}. \cr The function \code{parchmCopula} returns a numeric matrix with values computed for the Archemedean copula. \cr The function \code{darchmCopula} returns a numeric matrix with values computed for thedensity of the Archemedean copula. \cr The functions \code{Phi*} return a numeric vector with the values computed from the Archemedean generator, its derivatives, or its inverse. \cr The functions \code{cK} and \code{cKInv} return a numeric vector with the values of the density and inverse for Archimedian copulae. } \author{ Diethelm Wuertz for the Rmetrics \R-port. } % \examples{ % ## fCOPULA - % # getClass("fCOPULA") % ## pcopula - % # The default Normal Copula: % # contour(pcopula()) % } \keyword{models} fCopulae/man/ExtremeValueModelling.Rd0000644000176000001440000000632412406047540017352 0ustar ripleyusers\name{ExtremeValueModelling} \alias{ExtremeValueModelling} \alias{evCopulaSim} \alias{evCopulaFit} \title{Bivariate Extreme Value Copulae} \description{ A collection and description of functions to investigate bivariate extreme value copulae. \cr Extreme Value Copulae Functions: \tabular{ll}{ \code{evCopulaSim} \tab simulates an extreme value copula, \cr \code{evCopulaFit} \tab fits the parameters of an extreme value copula. } } \usage{ evCopulaSim(n, param = NULL, type = evList()) evCopulaFit(u, v = NULL, type = evList(), \dots) } \arguments{ \item{n}{ [revCopula][evCopulaSim] - \cr the number of random deviates to be generated, an integer value. } \item{param}{ [*ev*][A*] - \cr distribution and copulae parameters. A numeric value or vector of named parameters as required by the copula specified by the variable \code{type}. If set to \code{NULL}, then the default parameters will be taken. } \item{type}{ [*ev*][Afunc] - \cr the type of the extreme value copula. A character string selected from: "gumbel", "galambos", "husler.reiss", "tawn", or "bb5". \cr [evSlider] - \cr a character string specifying the plot type. Either a perspective plot which is the default or a contour plot with an underlying image plot will be created. } \item{u, v}{ [*evCopula][*archmCopula] - \cr two numeric values or vectors of the same length at which the copula will be computed. If \code{u} is a list then the the \code{$x} and \code{$y} elements will be used as \code{u} and \code{v}. If \code{u} is a two column matrix then the first column will be used as \code{u} and the the second as \code{v}. } \item{\dots}{ [evCopulaFit] - \cr arguments passed to the optimization function \code{nlminb}. } } \value{ The function \code{pcopula} returns a numeric matrix of probabilities computed at grid positions \code{x}|\code{y}. \cr The function \code{parchmCopula} returns a numeric matrix with values computed for the Archemedean copula. \cr The function \code{darchmCopula} returns a numeric matrix with values computed for thedensity of the Archemedean copula. \cr The functions \code{Phi*} return a numeric vector with the values computed from the Archemedean generator, its derivatives, or its inverse. \cr The functions \code{cK} and \code{cKInv} return a numeric vector with the values of the density and inverse for Archimedian copulae. } \author{ Diethelm Wuertz for the Rmetrics \R-port. } \examples{ ## fCOPULA - getClass("fCOPULA") getSlots("fCOPULA") ## revCopula - # Not yet implemented # revCopula(n = 10, type = "galambos") ## pevCopula - pevCopula(u = grid2d(), type = "galambos", output = "list") ## devCopula - devCopula(u = grid2d(), type = "galambos", output = "list") ## AfuncSlider - # Generator, try: \dontrun{AfuncSlider()} } \keyword{models} fCopulae/man/EllipticalCopulae.Rd0000644000176000001440000002053312406047540016502 0ustar ripleyusers\name{EllipticalCopulae} \alias{EllipticalCopulae} \alias{rellipticalCopula} \alias{pellipticalCopula} \alias{dellipticalCopula} \alias{rellipticalSlider} \alias{pellipticalSlider} \alias{dellipticalSlider} \title{Bivariate Elliptical Copulae} \description{ A collection and description of functions to investigate bivariate elliptical copulae. \cr Elliptical Copulae Functions: \tabular{ll}{ \code{rellipticalCopula} \tab Generates elliptical copula variates, \cr \code{pellipticalCopula} \tab computes elliptical copula probability, \cr \code{dellipticalCopula} \tab computes elliptical copula density, \cr \code{rellipticalSlider} \tab displays interactive plots of variates, \cr \code{pellipticalSlider} \tab displays interactive plots of probability, \cr \code{dellipticalSlider} \tab displays interactive plots of density. } } \usage{ rellipticalCopula(n, rho = 0.75, param = NULL, type = c("norm", "cauchy", "t")) pellipticalCopula(u = 0.5, v = u, rho = 0.75, param = NULL, type = ellipticalList(), output = c("vector", "list"), border = TRUE) dellipticalCopula(u = 0.5, v = u, rho = 0.75, param = NULL, type = ellipticalList(), output = c("vector", "list"), border = TRUE) rellipticalSlider(B = 100) pellipticalSlider(type = c("persp", "contour"), B = 20) dellipticalSlider(type = c("persp", "contour"), B = 20) } \arguments{ \item{B}{ [*Slider] - \cr the maximum slider menu value when the boundary value is infinite. By default this is set to 10. } \item{border}{ [pellipticalCopula][dellipticalCopula] - \cr a logical flag. If the argument \code{u} is an integer, say \code{N}, greater than one than all points on a square grid \code{[(0:N)/N]^2} are computed. If border is FALSE than the border points are removed from the returned value, by default this is not the case. } \item{n}{ [rellipticalCopula][ellipticalCopulaSim] - \cr the number of random deviates to be generated, an integer value. } \item{output}{ [pellipticalCopula][dellipticalCopula] - \cr a character string specifying how the output should be formatted. By default a vector of the same length as \code{u} and \code{v} is returned. If specified as \code{"list"} then \code{u} and \code{v} are expected to span a two-dimensional grid as outputted by the function \code{grid2d} and the function returns a list with elements \code{$x}, \code{y}, and \code{z} which can be directly used for example by 2D plotting functions. For the grid version, when \code{u} is specified as an integer greater than one, always the output in form of a list will be returned. } \item{rho}{ [*ellipticalCopula] - \cr is the numeric value setting the correlation strength, ranging between minus one and one. } \item{param}{ [*ellipticalCopula][gfunc] - \cr additional distributional parameters: for the Sudent-t distribution this is "nu", for the Kotz distribution this is "r", and for the Exponential Power distribution these are "r" and "s". If the argument \code{param=NULL} then default values are taken. These are for the Student-t \code{param=c(nu=4))}, for the Kotz distribution \code{param=c(r=1))}, and for the exponential power distribution \code{param=c(r=1,s=1)}. Note, that the Kotz and exponential power copulae are independent of \code{r}, and that \code{r} only enters the generator, the density, the probability and the quantile functions. } \item{type}{ [*ellipticalCopula][gfunc] - \cr the type of the elliptical copula. A character string selected from: "norm", "cauchy", "t", "logistic", "laplace", "kotz", or "epower". [*ellipticalSlider] - \cr a character string which indicates what kind of plot should be displayed, either a perspective plot if \code{type="persp"}, the default value, or a contour plot if \code{type="contour"}. } \item{u, v}{ [*ellipticalCopula] - \cr two numeric values or vectors of the same length at which the copula will be computed. If \code{u} is a list then the the \code{$x} and \code{$y} elements will be used as \code{u} and \code{v}. If \code{u} is a two column matrix then the first column will be used as \code{u} and the the second as \code{v}. If \code{u} is an integer value greater than one, say \code{N}, than the values for all points on the \code{[(0:N)/N]^2} grid spanning the unit square will be returned. } \item{\dots}{ [ellipticalCopulaFit] - \cr arguments passed to the optimization function \code{nlminb}. } } \value{ \bold{Copula Functions:} \cr\cr The functions \code{[rpd]ellipticalCopula} return a numeric vector of random variates, probabilities, or densities for the specified copula computed at grid coordinates \code{u}|\code{v}. \cr The functions \code{[rpd]ellipticalSlider} display an interactive graph of an perspective copula plot either for random variates, probabilities or densities. Alternatively, an image underlayed contour plot can be shown. \cr \bold{Copula Dependence Measures:} \cr\cr The functions \code{ellipticalTau} and \code{ellipticalRho} return a numericc value for Kendall's Tau and Spearman's Rho. \cr \bold{Copula Tail Coefficient:} \cr\cr The function \code{ellipticalTailCoeff} returns the coefficient of tail dependence for a specified copula. The function \code{ellipticalTailPlot} displays a whole plot for the upper or alternatively for the lower tail dependence as a function of \code{u} for a set of nine \code{rho} values. \cr \bold{Copula Generator Function:} \cr\cr The function \code{gfunc} computes the generator function for the specified copula, by default the normal copula. If the argument \code{x} is missing, then the normalization constand lambda will be returned, otherwise if \code{x} is specified the values for the function \emph{g(x)} will be freturned. The selected type of copula is added to the output as an attribute named \code{"control"}. The function \code{gfuncSlider} allows to display interactively the generator function, the marginal density, the marginal probability, and the contours of the the bivariate density. \cr \bold{Copula Simulation and Parameter Fitting:} \cr\cr The function \code{ellipticalCopulaSim} returns a numeric two-column matrix with randomly generated variates for the specified copula. \cr The function \code{ellipticalCopulaFit} returns a fit to empirical data for the specified copula. The returned object is a list with elements from the function \code{nlminb}. } \author{ Diethelm Wuertz for the Rmetrics \R-port. } \examples{ ## [rp]ellipticalCopula - # Default Normal Copula: rellipticalCopula(10) pellipticalCopula(10) ## [rp]ellipticalCopula - # Student-t Copula Probability and Density: u <- grid2d(x = (0:25)/25) pellipticalCopula(u, rho = 0.75, param = 4, type = "t", output = "list") d <- dellipticalCopula(u, rho = 0.75, param = 4, type = "t", output = "list") persp(d, theta = -40, phi = 30, col = "steelblue") ## ellipticalTau - ## ellipticalRho - # Dependence Measures: ellipticalTau(rho = -0.5) ellipticalRho(rho = 0.75, type = "logistic", subdivisions = 100) ## ellipticalTailCoeff - # Student-t Tail Coefficient: ellipticalTailCoeff(rho = 0.25, param = 3, type = "t") ## gfunc - # Generator Function: plot(gfunc(x = 0:10), main = "Generator Function") ## ellipticalCopulaSim - ## ellipticalCopulaSim - # Simualtion and Parameter Fitting: rv <- ellipticalCopulaSim(n = 100, rho = 0.75) ellipticalCopulaFit(rv) } \keyword{models} fCopulae/man/EmpiricalCopulae.Rd0000644000176000001440000000527412406047540016332 0ustar ripleyusers\name{EmpiricalCopulae} \alias{EmpiricalCopulae} \alias{pempiricalCopula} \alias{dempiricalCopula} \title{Bivariate Empirical Copulae} \description{ A collection and description of functions to investigate bivariate empirical copulae. \cr Empirical Copulae Functions: \tabular{ll}{ \code{pempiricalCopula} \tab computes empirical copula probability, \cr \code{dempiricalCopula} \tab computes empirical copula density. } } \usage{ pempiricalCopula(u, v, N = 10) dempiricalCopula(u, v, N = 10) } \arguments{ \item{N}{ [empiricalCopula] - \cr ... . } \item{u, v}{ [*evCopula][*archmCopula] - \cr two numeric values or vectors of the same length at which the copula will be computed. If \code{u} is a list then the the \code{$x} and \code{$y} elements will be used as \code{u} and \code{v}. If \code{u} is a two column matrix then the first column will be used as \code{u} and the the second as \code{v}. } } \value{ Th functions \code{*Spec} return an S4 object of class \code{"fCOPULA"}. The object contains the following slots: \item{@call}{ the function call. } \item{@copula}{ the name of the copula. } \item{@param}{ a list whose elements specify the model parameters. } \item{@title}{ a character string with the name of the copula. This can be overwritten specifying a user defined input argument. } \item{@description}{ a character string with an optional user defined description. By default just the current date when the test was applied will be returned. } The function \code{pcopula} returns a numeric matrix of probabilities computed at grid positions \code{x}|\code{y}. \cr The function \code{parchmCopula} returns a numeric matrix with values computed for the Archemedean copula. \cr The function \code{darchmCopula} returns a numeric matrix with values computed for thedensity of the Archemedean copula. \cr The functions \code{Phi*} return a numeric vector with the values computed from the Archemedean generator, its derivatives, or its inverse. \cr The functions \code{cK} and \code{cKInv} return a numeric vector with the values of the density and inverse for Archimedian copulae. } \author{ Diethelm Wuertz for the Rmetrics \R-port. } % \examples{ % ## fCOPULA - % # getClass("fCOPULA") % ## pcopula - % # The default Normal Copula: % # contour(pcopula()) % } \keyword{models} fCopulae/man/ArchimedeanDependency.Rd0000644000176000001440000000625212406047540017310 0ustar ripleyusers\name{ArchimedeanDependency} \alias{ArchimedeanDependency} \alias{archmTau} \alias{archmRho} \alias{archmTailCoeff} \alias{archmTailPlot} \title{Bivariate Archimedean Copulae} \description{ A collection and description of functions to investigate bivariate Archimedean copulae. \cr Archimedean Copulae Functions: \tabular{ll}{ \code{archmTau} \tab Computes Kendall's tau for Archimedean copulae, \cr \code{archmRho} \tab computes Spearman's rho for Archimedean copulae, \cr \code{archmTailCoeff} \tab computes tail dependence for Archimedean copulae, \cr \code{archmTailPlot} \tab plots tail dependence for Archimedean copulae. } } \usage{ archmTau(alpha = NULL, type = archmList(), lower = 1.0e-10) archmRho(alpha = NULL, type = archmList(), method = c("integrate2d", "adapt"), error = 1.0e-5) archmTailCoeff(alpha = NULL, type = archmList()) archmTailPlot(alpha = NULL, type = archmList(), tail = c("Upper", "Lower")) } \arguments{ \item{alpha}{ the parameter of the Archemedean copula. A numerical value. } \item{error}{ [archmRho] - \cr the error bound to be achieved by the \code{integrate2d} integration formula. A numeric value, by default \code{error=1.0e-5}. } \item{lower}{ [archmTau] - \cr a numeric value setting the lower bound for the internal integration function \code{integrate}. } \item{tail}{ [archmTailPlot] - \cr a character string, either \code{"Upper"} or \code{"Lower"} denoting which of the two tails should be displayed. By default the upper tail dependence will be considered. } \item{type}{ the type of the Archimedean copula. A character string ranging beween \code{"1"} and \code{"22"}. By default copula No. 1 will be chosen. } \item{method}{ [archmRho] - \cr a character string that determines which integration method should be used, either \code{"integrate2d"} or \code{"adapt"}. If the second method is selected the contributed R package \code{"adapt"} is required. } } \value{ The function \code{pcopula} returns a numeric matrix of probabilities computed at grid positions \code{x}|\code{y}. \cr The function \code{parchmCopula} returns a numeric matrix with values computed for the Archemedean copula. \cr The function \code{darchmCopula} returns a numeric matrix with values computed for thedensity of the Archemedean copula. \cr The functions \code{Phi*} return a numeric vector with the values computed from the Archemedean generator, its derivatives, or its inverse. \cr The functions \code{cK} and \code{cKInv} return a numeric vector with the values of the density and inverse for Archimedian copulae. } \author{ Diethelm Wuertz for the Rmetrics \R-port. } % \examples{ % ## fCOPULA - % # getClass("fCOPULA") % ## pcopula - % # The default Normal Copula: % # contour(pcopula()) % } \keyword{models} fCopulae/man/00fCopulae-package.Rd0000644000176000001440000001643312406047540016402 0ustar ripleyusers\name{fCopulae-package} \alias{fCopulae-package} \alias{fCopulae} \docType{package} \title{Modelling Copulae and Dependence Structures} \description{ The Rmetrics \code{fCopulae} package is a collection of functions to manage, to investigate and to analyze bivariate financial returns by Copulae. Included are the families of Archemedean, Elliptical, Extreme Value, and Empirical Copulae. } \details{ \tabular{ll}{ Package: \tab fCopulae\cr Type: \tab Package\cr Version: \tab R 3.0.1\cr Date: \tab 2014\cr License: \tab GPL Version 2 or later\cr Copyright: \tab (c) 1999-2014 Rmetrics Assiciation\cr URL: \tab \url{https://www.rmetrics.org} } } \section{1 Introduction}{ The package \code{fCoplae} was written to explore and investigate bivariate copulae and dependence structures. } \section{2 Archimedean Copulae}{ This chapter contains functions for analysing and modeling Archemedean copulae. \emph{Archimedean Copula Density, Probability and Random Numbers:} \preformatted{ darchmCopula Computes Archimedean copula density parchmCopula Computes Archimedean copula probability rarchmCopula Generates Archimedean copula random variates } For the Gumbel Copula we have a fast implementation. \preformatted{ rgumbelCopula Generates fast gumbel random variates dgumbelCopula Computes bivariate Gumbel copula density pgumbelCopula Computes bivariate Gumbel copula probability } \emph{Archimedean Copula Dependency Structure:} \preformatted{ archmTau Returns Kendall's tau for Archemedean copulae archmRho Returns Spearman's rho for Archemedean copulae } \preformatted{ archmTailCoeff Computes tail dependence for Archimedean copulae archmTailPlot Plots Archimedean tail dependence function } \emph{Archimedean Copula Generator:} \preformatted{ archmList Returns list of implemented Archimedean copulae archmParam Sets Default parameters for an Archimedean copula archmRange Returns the range of valid alpha values archmCheck Checks if alpha is in the valid range } \preformatted{ Phi Computes Archimedean Phi, inverse and derivatives PhiSlider Displays interactively generator function Kfunc Computes Archimedean Density Kc and its Inverse KfuncSlider Displays interactively the density and concordance } \emph{Archemedean Copula Modeling:} \preformatted{ archmCopulaSim Simulates bivariate elliptical copula archmCopulaFit Fits the paramter of an elliptical copula } \emph{Archemedean Copula Slider:} \preformatted{ darchmSlider Displays interactively archimedean density parchmSlider Displays interactively Archimedean probability rarchmSlider Displays interactively Archimedean probability } } \section{3 Elliptical Copulae}{ This chapter contains functions for analysing and modeling elliptical copulae. \emph{Elliptical Copula Density, Probability and Random Numbers:} \preformatted{ dellipticalCopula Computes elliptical copula density pellipticalCopula Computes elliptical copula probability rellipticalCopula Generates elliptical copula variates } \emph{Elliptical Copula Slider:} \preformatted{ dellipticalSlider Generates interactive plots of density pellipticalSlider Generates interactive plots of probability rellipticalSlider Generates interactive plots of random variates } \emph{Elliptical Copula Dependency Structures:} \preformatted{ ellipticalTau Computes Kendall's tau for elliptical copulae ellipticalRho Computes Spearman's rho for elliptical copulae } \preformatted{ ellipticalTailCoeff Computes tail dependence for elliptical copulae ellipticalTailPlot Plots tail dependence function } \emph{Elliptical Copula Generator:} \preformatted{ ellipticalList Returns list of implemented Elliptical copulae ellipticalParam Sets default parameters for an elliptical copula ellipticalRange Returns the range of valid rho values ellipticalCheck Checks if rho is in the valid range } \preformatted{ gfunc Generator function for elliptical distributions gfuncSlider Slider for generator, density and probability } \emph{Elliptical Copula Modeling:} \preformatted{ ellipticalCopulaSim Simulates bivariate elliptical copula ellipticalCopulaFit Fits the paramter of an elliptical copula } } \section{4 Extreme Value Copulae}{ This chapter contains functions for analysing and modeling extreme value copulae. \emph{Extremem Value Copula Density, Probability and Random Numbers:} \preformatted{ devCopula Computes extreme value copula density pevCopula Computes extreme value copula probability revCopula Generates extreme value copula random variates } \preformatted{ devSlider Displays interactively plots of density pevSlider Displays interactively plots of probability revSlider isplays interactively plots of random variates } \emph{Extreme Value Copula Dependeny Structures:} \preformatted{ evTau Returns Kendall's tau for extreme value copulae evRho Returns Spearman's rho for extreme value copulae } \preformatted{ evTailCoeff Computes tail dependence for extreme value copulae evTailCoeffSlider Plots extreme value tail dependence function } \emph{Extreme Value Copula Generator:} \preformatted{ evList Returns list of implemented extreme value copulae evParam Sets Default parameters for an extreme value copula evCheck Checks if parameters are in the valid range evRange Returns the range of valid parameter values } \preformatted{ Afunc Computes Dependence function AfuncSlider Displays interactively dependence function } \emph{Extreme Value Copula Modeling:} \preformatted{ evCopulaSim Simulates bivariate extreme value copula evCopulaFit Fits the paramter of an extreme value copula } } \section{5 Empirical Copula.}{ This chapter contains functions for analysing and modeling empirical copulae. \emph{Empirical Copulae Density and Probability:} \preformatted{ pempiricalCopula Computes empirical copula probability dempiricalCopula Computes empirical copula density } } \section{About Rmetrics:}{ The \code{fCopulae} Rmetrics package is written for educational support in teaching "Computational Finance and Financial Engineering" and licensed under the GPL. } \keyword{package}