Nothing
#############################################################################
# Copyright (c) 2012 Christophe Dutang
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# This program 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 General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the
# Free Software Foundation, Inc.,
# 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA
#
#############################################################################
### utility functions for constrained equations in GNE
###
### R functions
###
#functions of the Constrained Equation Reformulation of the GNEP
#z = (x, lambda, mu, w, y)
#or (x, lambda tilde, w tilde) with lambda tilde = (lambda, mu) and w tilde = (w, y)
testargfunCER <- function(z, dimx, dimlam,
grobj, arggrobj,
constr, argconstr,
grconstr, arggrconstr,
dimmu, joint, argjoint,
grjoint, arggrjoint,
echo=FALSE)
{
#sanity check
nplayer <- length(dimx)
if(!is.function(grobj))
stop("argument grobj must be a function.")
if(missing(constr))
constr <- NULL
else if(!is.function(constr) && !is.null(constr))
stop("argument constr must be a function.")
if(!is.null(constr) && missing(grconstr))
stop("argument grconstr incompatible with constr.")
else if(!is.null(constr) && !is.function(grconstr))
stop("argument grconstr must be a function.")
if(is.null(constr))
dimlam <- rep(0, nplayer)
else if(!is.null(constr) && (missing(dimlam) || length(dimlam) != nplayer))
stop(paste("argument dimlam must be a vector of length", nplayer, "."))
if(missing(joint))
joint <- NULL
else if(!is.function(joint) && !is.null(joint))
stop("argument joint must be a function.")
if(!is.null(joint) && missing(grjoint))
stop("argument grjoint incompatible with joint.")
else if(!is.null(joint) && !is.function(grjoint))
stop("argument grjoint must be a function.")
if(is.null(joint))
dimmu <- 0
else if(!is.null(joint) && (missing(dimmu) || length(dimmu) != 1))
stop("argument dimmu must be a vector of length 1.")
if(echo)
{
print(dimx)
print(dimlam)
print(length(z))
}
if(length(z) != sum(dimx) + 2*sum(dimlam) + 2*sum(dimmu))
stop("CER: incompatible dimension for dimlam, dimx, dimmu.")
#objective gradient
if(!missing(arggrobj) && !is.null(arggrobj))
grobjfinal <- grobj
else
{
grobjfinal <- function(z, i, j, ...) grobj(z, i, j)
arggrobj <- list()
}
str <- paste("the call to grobj(z, 1, 1, arggrobj) does not work.", "arguments are",
paste(names(formals(grobj)), collapse=","), ".")
testfunc(grobjfinal, z, arg=arggrobj, echo=echo, errmess=str)
#constraint
if(!is.null(constr))
{
if(!missing(argconstr) && !is.null(argconstr))
constrfinal <- constr
else
{
constrfinal <- function(z, i, ...) constr(z, i)
argconstr <- list()
}
str <- paste("the call to constr(z, 1, argconstr) does not work.", "arguments are",
paste(names(formals(constr)), collapse=","), ".")
testfunc(constrfinal, z, arg=argconstr, echo=echo, errmess=str)
#constraint gradient
if(!missing(arggrconstr) && !is.null(arggrconstr))
grconstrfinal <- grconstr
else
{
grconstrfinal <- function(z, i, j, ...) grconstr(z, i, j)
arggrconstr <- list()
}
str <- paste("the call to grconstr(z, 1, 1, arggrconstr) does not work.", "arguments are",
paste(names(formals(grconstr)), collapse=","), ".")
testfunc(grconstrfinal, z, arg=arggrconstr, echo=echo, errmess=str)
}else
{
constrfinal <- grconstrfinal <- argconstr <- arggrconstr <- NULL
}
#joint constraint function
if(!is.null(joint))
{
if(!missing(argjoint) && !is.null(argjoint))
jointfinal <- joint
else
{
jointfinal <- function(z, ...) joint(z)
argjoint <- list()
}
str <- paste("the call to joint(z, argconstr) does not work.", "arguments are",
paste(names(formals(joint)), collapse=","), ".")
testfunc(jointfinal, z, arg=argjoint, echo=echo, errmess=str)
#gradient
if(!missing(arggrjoint) && !is.null(arggrjoint))
grjointfinal <- grjoint
else
{
grjointfinal <- function(z, j, ...) grjoint(z, j)
arggrjoint <- list()
}
str <- paste("the call to grjoint(z, 1, arggrjoint) does not work.", "arguments are",
paste(names(formals(grjoint)), collapse=","), ".")
testfunc(grjointfinal, z, arg=arggrjoint, echo=echo, errmess=str)
}else
{
jointfinal <- grjointfinal <- argjoint <- arggrjoint <- NULL
}
list(grobj=grobjfinal, arggrobj=arggrobj, constr=constrfinal, argconstr=argconstr,
grconstr=grconstrfinal, arggrconstr=arggrconstr, joint=jointfinal,
argjoint=argjoint, grjoint=grjointfinal, arggrjoint=arggrjoint,
dimx=dimx, dimlam=dimlam, dimmu=dimmu, nplayer=nplayer)
}
testargjacCER <- function(z, dimx, dimlam,
heobj, argheobj,
constr, argconstr,
grconstr, arggrconstr,
heconstr, argheconstr,
dimmu, joint, argjoint,
grjoint, arggrjoint,
hejoint, arghejoint,
echo=FALSE)
{
#sanity check
nplayer <- length(dimx)
if(!is.function(heobj))
stop("argument heobj must be a function.")
if(missing(constr))
constr <- NULL
else if(!is.function(constr) && !is.null(constr))
stop("argument constr must be a function.")
if(!is.null(constr) && missing(grconstr))
stop("argument grconstr incompatible with constr.")
else if(!is.null(constr) && !is.function(grconstr))
stop("argument grconstr must be a function.")
else if(!is.null(constr) && !is.function(heconstr))
stop("argument heconstr must be a function.")
if(is.null(constr))
dimlam <- rep(0, nplayer)
else if(!is.null(constr) && (missing(dimlam) || length(dimlam) != nplayer))
stop(paste("argument dimlam must be a vector of length", nplayer, "."))
if(missing(joint))
joint <- NULL
else if(!is.function(joint) && !is.null(joint))
stop("argument joint must be a function.")
if(!is.null(joint) && missing(grjoint))
stop("argument grjoint incompatible with joint.")
else if(!is.null(joint) && !is.function(grjoint))
stop("argument grjoint must be a function.")
else if(!is.null(joint) && !is.function(hejoint))
stop("argument hejoint must be a function.")
if(is.null(joint))
dimmu <- 0
else if(!is.null(joint) && (missing(dimmu) || length(dimmu) != 1))
stop("argument dimmu must be a vector of length 1.")
if(length(z) != sum(dimx) + 2*sum(dimlam) + 2*sum(dimmu))
stop("incompatible dimension for dimlam, dimx, dimmu.")
#objective Hessian
if(!missing(argheobj) && !is.null(argheobj))
heobjfinal <- heobj
else
{
heobjfinal <- function(z, i, j, k, ...) heobj(z, i, j, k)
argheobj <- list()
}
str <- paste("the call to heobj(z, 1, 1, 1, argheobj) does not work.", "arguments are",
paste(names(formals(heobj)), collapse=","), ".")
testfunc(heobjfinal, z, arg=argheobj, echo=echo, errmess=str)
#constraint
if(!is.null(constr))
{
if(!missing(argconstr) && !is.null(argconstr))
constrfinal <- constr
else
{
constrfinal <- function(z, i, ...) constr(z, i)
argconstr <- list()
}
str <- paste("the call to constr(z, 1, argconstr) does not work.", "arguments are",
paste(names(formals(constr)), collapse=","), ".")
testfunc(constrfinal, z, arg=argconstr, echo=echo, errmess=str)
#constraint gradient
if(!missing(arggrconstr) && !is.null(arggrconstr))
grconstrfinal <- grconstr
else
{
grconstrfinal <- function(z, i, j, ...) grconstr(z, i, j)
arggrconstr <- list()
}
str <- paste("the call to grconstr(z, 1, 1, arggrconstr) does not work.", "arguments are",
paste(names(formals(grconstr)), collapse=","), ".")
testfunc(grconstrfinal, z, arg=arggrconstr, echo=echo, errmess=str)
#constraint hessian
if(!missing(argheconstr) && !is.null(argheconstr))
heconstrfinal <- heconstr
else
{
heconstrfinal <- function(z, i, j, k, ...) heconstr(z, i, j, k)
argheconstr <- list()
}
str <- paste("the call to heconstr(z, 1, 1, 1, argheconstr) does not work.", "arguments are",
paste(names(formals(heconstr)), collapse=","), ".")
testfunc(heconstrfinal, z, arg=argheconstr, echo=echo, errmess=str)
}else
{
constrfinal <- grconstrfinal <- heconstrfinal <- argconstr <- arggrconstr <- argheconstr <- NULL
}
#joint constraint function
if(!is.null(joint))
{
if(!missing(argjoint) && !is.null(argjoint))
jointfinal <- joint
else
{
jointfinal <- function(z, ...) joint(z)
argjoint <- list()
}
str <- paste("the call to joint(z, argconstr) does not work.", "arguments are",
paste(names(formals(joint)), collapse=","), ".")
testfunc(jointfinal, z, arg=argjoint, echo=echo, errmess=str)
#gradient
if(!missing(arggrjoint) && !is.null(arggrjoint))
grjointfinal <- grjoint
else
{
grjointfinal <- function(z, j, ...) grjoint(z, j)
arggrjoint <- list()
}
str <- paste("the call to grjoint(z, 1, arggrjoint) does not work.", "arguments are",
paste(names(formals(grjoint)), collapse=","), ".")
testfunc(grjointfinal, z, arg=arggrjoint, echo=echo, errmess=str)
#hessian
if(!missing(arghejoint) && !is.null(arghejoint))
hejointfinal <- hejoint
else
{
hejointfinal <- function(z, j, k, ...) hejoint(z, j, k)
arghejoint <- list()
}
str <- paste("the call to hejoint(z, 1, 1, arghejoint) does not work.", "arguments are",
paste(names(formals(hejoint)), collapse=","), ".")
testfunc(hejointfinal, z, arg=arghejoint, echo=echo, errmess=str)
}else
{
jointfinal <- grjointfinal <- hejointfinal <- argjoint <- arggrjoint <- arghejoint <- NULL
}
list(heobj=heobjfinal, argheobj=argheobj, constr=constrfinal, argconstr=argconstr,
grconstr=grconstrfinal, arggrconstr=arggrconstr, heconstr=heconstrfinal,
argheconstr=argheconstr, joint=jointfinal, argjoint=argjoint, grjoint=grjointfinal,
arggrjoint=arggrjoint, hejoint=hejointfinal, arghejoint=arghejoint,
dimx=dimx, dimlam=dimlam, dimmu=dimmu, nplayer=nplayer)
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.