Last updated on 2023-03-31 07:53:27 CEST.
| Flavor | Version | Tinstall | Tcheck | Ttotal | Status | Flags |
|---|---|---|---|---|---|---|
| r-devel-linux-x86_64-debian-clang | 0.99-4 | 9.80 | 85.60 | 95.40 | ERROR | |
| r-devel-linux-x86_64-debian-gcc | 0.99-4 | 8.59 | 65.00 | 73.59 | ERROR | |
| r-devel-linux-x86_64-fedora-clang | 0.99-5 | 140.96 | OK | |||
| r-devel-linux-x86_64-fedora-gcc | 0.99-5 | 154.66 | OK | |||
| r-devel-windows-x86_64 | 0.99-4 | 40.00 | 0.00 | 40.00 | ERROR | |
| r-patched-linux-x86_64 | 0.99-4 | 12.95 | 82.19 | 95.14 | ERROR | |
| r-release-linux-x86_64 | 0.99-4 | 9.39 | 103.04 | 112.43 | OK | |
| r-release-macos-arm64 | 0.99-4 | 46.00 | OK | |||
| r-release-macos-x86_64 | 0.99-4 | 58.00 | OK | |||
| r-release-windows-x86_64 | 0.99-4 | 50.00 | 173.00 | 223.00 | OK | |
| r-oldrel-macos-arm64 | 0.99-4 | 46.00 | OK | |||
| r-oldrel-macos-x86_64 | 0.99-4 | 58.00 | OK | |||
| r-oldrel-windows-ix86+x86_64 | 0.99-4 | 22.00 | 180.00 | 202.00 | OK |
Version: 0.99-4
Check: examples
Result: ERROR
Running examples in ‘GNE-Ex.R’ failed
The error most likely occurred in:
> base::assign(".ptime", proc.time(), pos = "CheckExEnv")
> ### Name: GNE.nseq
> ### Title: Non smooth equation reformulation of the GNE problem.
> ### Aliases: GNE.nseq
> ### Keywords: nonlinear optimize
>
> ### ** Examples
>
>
>
> #-------------------------------------------------------------------------------
> # (1) Example 5 of von Facchinei et al. (2007)
> #-------------------------------------------------------------------------------
>
> dimx <- c(1, 1)
> #Gr_x_j O_i(x)
> grobj <- function(x, i, j)
+ {
+ if(i == 1)
+ res <- c(2*(x[1]-1), 0)
+ if(i == 2)
+ res <- c(0, 2*(x[2]-1/2))
+ res[j]
+ }
> #Gr_x_k Gr_x_j O_i(x)
> heobj <- function(x, i, j, k)
+ 2 * (i == j && j == k)
>
> dimlam <- c(1, 1)
> #constraint function g_i(x)
> g <- function(x, i)
+ sum(x[1:2]) - 1
> #Gr_x_j g_i(x)
> grg <- function(x, i, j)
+ 1
> #Gr_x_k Gr_x_j g_i(x)
> heg <- function(x, i, j, k)
+ 0
>
>
>
> #true value is (3/4, 1/4, 1/2, 1/2)
>
> z0 <- rep(0, sum(dimx)+sum(dimlam))
>
> funSSR(z0, dimx, dimlam, grobj=grobj, constr=g, grconstr=grg, compl=phiFB, echo=FALSE)
Error in funSSR(z0, dimx, dimlam, grobj = grobj, constr = g, grconstr = grg, :
DLL requires the use of native symbols
Execution halted
Flavors: r-devel-linux-x86_64-debian-clang, r-devel-linux-x86_64-debian-gcc, r-patched-linux-x86_64
Version: 0.99-4
Check: tests
Result: ERROR
Running ‘CER-funCER-Rcode-constr.R’ [1s/1s]
Running ‘CER-funCER-Rcode-constrjoint.R’ [1s/1s]
Running ‘CER-funCER-Rcode-joint.R’ [1s/1s]
Running ‘GNEceq-examples.R’ [1s/1s]
Running ‘GNEnseq-examples.R’ [0s/1s]
Running ‘NIR-func-Rcode.R’ [6s/7s]
Running ‘NIRandVIPexample.R’ [1s/2s]
Running ‘SSR-Rcode-funSSRcheck-constrjoint.R’ [1s/1s]
Running ‘SSR-funSSR-Rcode-constr.R’ [1s/1s]
Running ‘SSR-funSSR-funSSRcheck-constr.R’ [1s/1s]
Running ‘SSR-funSSR-funSSRcheck-constrjoint.R’ [1s/1s]
Running ‘SSR-testarg.R’ [0s/1s]
Running ‘complfunc-3Dplot.R’ [1s/1s]
Running ‘complfunc-funcFB.R’ [0s/1s]
Running ‘complfunc-limitgraph.R’ [1s/1s]
Running ‘sensi-analysis-duopoly.R’ [0s/1s]
Running ‘sensi-analysis-genduopoly.R’ [6s/8s]
Running ‘sensi-analysis-riverbasinpollution.R’ [1s/1s]
Running ‘util-testfunc.R’ [0s/1s]
Running the tests in ‘tests/CER-funCER-Rcode-constr.R’ failed.
Complete output:
> if(!require("GNE"))stop("this test requires package GNE.")
Loading required package: GNE
Loading required package: alabama
Loading required package: numDeriv
Loading required package: nleqslv
Loading required package: BB
Loading required package: SQUAREM
>
>
>
> # (1) associated objective functions
> #
>
> dimx <- c(2, 2, 3)
>
> #Gr_x_j O_i(x)
> grfullob <- function(x, i, j)
+ {
+ x <- x[1:7]
+ if(i == 1)
+ {
+ grad <- 3*(x - 1:7)^2
+ }
+ if(i == 2)
+ {
+ grad <- 1:7*(x - 1:7)^(0:6)
+ }
+ if(i == 3)
+ {
+ s <- x[5]^2 + x[6]^2 + x[7]^2 - 5
+ grad <- c(1, 0, 1, 0, 4*x[5]*s, 4*x[6]*s, 4*x[7]*s)
+
+ }
+ grad[j]
+ }
>
>
> #Gr_x_k Gr_x_j O_i(x)
> hefullob <- function(x, i, j, k)
+ {
+ x <- x[1:7]
+ if(i == 1)
+ {
+ he <- diag( 6*(x - 1:7) )
+ }
+ if(i == 2)
+ {
+ he <- diag( c(0, 2, 6, 12, 20, 30, 42)*(x - 1:7)^c(0, 0:5) )
+ }
+ if(i == 3)
+ {
+ s <- x[5]^2 + x[6]^2 + x[7]^2
+
+ he <- rbind(rep(0, 7), rep(0, 7), rep(0, 7), rep(0, 7),
+ c(0, 0, 0, 0, 4*s+8*x[5]^2, 8*x[5]*x[6], 8*x[5]*x[7]),
+ c(0, 0, 0, 0, 8*x[5]*x[6], 4*s+8*x[6]^2, 8*x[6]*x[7]),
+ c(0, 0, 0, 0, 8*x[5]*x[7], 8*x[6]*x[7], 4*s+8*x[7]^2) )
+ }
+ he[j,k]
+ }
>
>
>
> # (2) constraint linked functions
> #
>
> dimlam <- dimw <- c(1, 2, 2)
>
> #constraint function g_i(x)
> g <- function(x, i)
+ {
+ x <- x[1:7]
+ #cat(x[1:5], "|", i, "\n")
+ if(i == 1)
+ res <- sum( x^(1:7) ) -7
+ if(i == 2)
+ res <- c(sum(x) + prod(x) - 14, 20 - sum(x))
+ if(i == 3)
+ res <- c(sum(x^2) + 1, 100 - sum(x))
+ #cat("res", res + par$a, "\n")
+ res
+ }
>
>
> #Gr_x_j g_i(x)
> grfullg <- function(x, i, j)
+ {
+ x <- x[1:7]
+ if(i == 1)
+ {
+ grad <- (1:7) * x ^ (0:6)
+ }
+ if(i == 2)
+ {
+ grad <- 1 + sapply(1:7, function(i) prod(x[-i]))
+ grad <- cbind(grad, -1)
+ }
+ if(i == 3)
+ {
+ grad <- cbind(2*x, -1)
+ }
+
+
+ if(i == 1)
+ res <- grad[j]
+ if(i != 1)
+ res <- grad[j,]
+ as.numeric(res)
+ }
>
>
>
> #Gr_x_k Gr_x_j g_i(x)
> hefullg <- function(x, i, j, k)
+ {
+ x <- x[1:7]
+ if(i == 1)
+ {
+ he1 <- diag( c(0, 2, 6, 12, 20, 30, 42) * x ^ c(0, 0, 1:5) )
+ }
+ if(i == 2)
+ {
+ he1 <- matrix(0, 7, 7)
+ he1[1, -1] <- sapply(2:7, function(i) prod(x[-c(1, i)]))
+ he1[2, -2] <- sapply(c(1, 3:7), function(i) prod(x[-c(2, i)]))
+ he1[3, -3] <- sapply(c(1:2, 4:7), function(i) prod(x[-c(3, i)]))
+ he1[4, -4] <- sapply(c(1:3, 5:7), function(i) prod(x[-c(4, i)]))
+ he1[5, -5] <- sapply(c(1:4, 6:7), function(i) prod(x[-c(5, i)]))
+ he1[6, -6] <- sapply(c(1:5, 7:7), function(i) prod(x[-c(6, i)]))
+ he1[7, -7] <- sapply(1:6, function(i) prod(x[-c(7, i)]))
+
+
+ he2 <- matrix(0, 7, 7)
+
+ }
+ if(i == 3)
+ {
+ he1 <- diag(rep(2, 7))
+ he2 <- matrix(0, 7, 7)
+ }
+ if(i != 1)
+ return( c(he1[j, k], he2[j, k]) )
+ else
+ return( he1[j, k] )
+ }
>
>
>
>
> # (3) compute H
> #
>
> z <- rexp(sum(dimx) + sum(dimlam) + sum(dimw))
>
> n <- sum(dimx)
> m <- sum(dimlam)
> x <- z[1:n]
> lam <- z[(n+1):(n+m)]
> w <- z[(n+m+1):(n+m+m)]
>
> resphi <- funCER(z, dimx, dimlam, grobj=grfullob, constr=g, grconstr=grfullg, echo=TRUE)
[1] 2 2 3
[1] 1 2 2
[1] 17
Error in funSSR(z[1:(n + m + dimmu)], dimx, dimlam, grobj, arggrobj, constr, :
DLL requires the use of native symbols
Calls: funCER -> funSSR
Execution halted
Running the tests in ‘tests/CER-funCER-Rcode-constrjoint.R’ failed.
Complete output:
> if(!require("GNE"))stop("this test requires package GNE.")
Loading required package: GNE
Loading required package: alabama
Loading required package: numDeriv
Loading required package: nleqslv
Loading required package: BB
Loading required package: SQUAREM
>
>
> # (1) associated objective functions
> #
>
> dimx <- c(2, 2, 3)
>
> #Gr_x_j O_i(x)
> grfullob <- function(x, i, j)
+ {
+ x <- x[1:7]
+ if(i == 1)
+ {
+ grad <- 3*(x - 1:7)^2
+ }
+ if(i == 2)
+ {
+ grad <- 1:7*(x - 1:7)^(0:6)
+ }
+ if(i == 3)
+ {
+ s <- x[5]^2 + x[6]^2 + x[7]^2 - 5
+ grad <- c(1, 0, 1, 0, 4*x[5]*s, 4*x[6]*s, 4*x[7]*s)
+
+ }
+ grad[j]
+ }
>
>
> #Gr_x_k Gr_x_j O_i(x)
> hefullob <- function(x, i, j, k)
+ {
+ x <- x[1:7]
+ if(i == 1)
+ {
+ he <- diag( 6*(x - 1:7) )
+ }
+ if(i == 2)
+ {
+ he <- diag( c(0, 2, 6, 12, 20, 30, 42)*(x - 1:7)^c(0, 0:5) )
+ }
+ if(i == 3)
+ {
+ s <- x[5]^2 + x[6]^2 + x[7]^2
+
+ he <- rbind(rep(0, 7), rep(0, 7), rep(0, 7), rep(0, 7),
+ c(0, 0, 0, 0, 4*s+8*x[5]^2, 8*x[5]*x[6], 8*x[5]*x[7]),
+ c(0, 0, 0, 0, 8*x[5]*x[6], 4*s+8*x[6]^2, 8*x[6]*x[7]),
+ c(0, 0, 0, 0, 8*x[5]*x[7], 8*x[6]*x[7], 4*s+8*x[7]^2) )
+ }
+ he[j,k]
+ }
>
>
>
> # (2) constraint linked functions
> #
>
> dimlam <- dimw <- c(1, 2, 2)
>
> #constraint function g_i(x)
> g <- function(x, i)
+ {
+ x <- x[1:7]
+ #cat(x[1:5], "|", i, "\n")
+ if(i == 1)
+ res <- sum( x^(1:7) ) -7
+ if(i == 2)
+ res <- c(sum(x) + prod(x) - 14, 20 - sum(x))
+ if(i == 3)
+ res <- c(sum(x^2) + 1, 100 - sum(x))
+ #cat("res", res + par$a, "\n")
+ res
+ }
>
>
> #Gr_x_j g_i(x)
> grfullg <- function(x, i, j)
+ {
+ x <- x[1:7]
+ if(i == 1)
+ {
+ grad <- (1:7) * x ^ (0:6)
+ }
+ if(i == 2)
+ {
+ grad <- 1 + sapply(1:7, function(i) prod(x[-i]))
+ grad <- cbind(grad, -1)
+ }
+ if(i == 3)
+ {
+ grad <- cbind(2*x, -1)
+ }
+
+
+ if(i == 1)
+ res <- grad[j]
+ if(i != 1)
+ res <- grad[j,]
+ as.numeric(res)
+ }
>
>
>
> #Gr_x_k Gr_x_j g_i(x)
> hefullg <- function(x, i, j, k)
+ {
+ x <- x[1:7]
+ if(i == 1)
+ {
+ he1 <- diag( c(0, 2, 6, 12, 20, 30, 42) * x ^ c(0, 0, 1:5) )
+ }
+ if(i == 2)
+ {
+ he1 <- matrix(0, 7, 7)
+ he1[1, -1] <- sapply(2:7, function(i) prod(x[-c(1, i)]))
+ he1[2, -2] <- sapply(c(1, 3:7), function(i) prod(x[-c(2, i)]))
+ he1[3, -3] <- sapply(c(1:2, 4:7), function(i) prod(x[-c(3, i)]))
+ he1[4, -4] <- sapply(c(1:3, 5:7), function(i) prod(x[-c(4, i)]))
+ he1[5, -5] <- sapply(c(1:4, 6:7), function(i) prod(x[-c(5, i)]))
+ he1[6, -6] <- sapply(c(1:5, 7:7), function(i) prod(x[-c(6, i)]))
+ he1[7, -7] <- sapply(1:6, function(i) prod(x[-c(7, i)]))
+ he2 <- matrix(0, 7, 7)
+ }
+ if(i == 3)
+ {
+ he1 <- diag(rep(2, 7))
+ he2 <- matrix(0, 7, 7)
+ }
+ if(i != 1)
+ return( c(he1[j, k], he2[j, k]) )
+ else
+ return( he1[j, k] )
+ }
>
>
> dimmu <- 3
>
> #constraint function h(x)
> h <- function(x)
+ {
+ x <- x[1:7]
+ c(prod(x) - 1, sum(x^2) -2, sum(x^3) -3)
+ }
> grh <- function(x, j)
+ {
+ x <- x[1:7]
+ c(prod(x[-j]), 2*x[j], 3*x[j]^2)
+ }
> heh <- function(x, j, k)
+ {
+ x <- x[1:7]
+ c(prod(x[-c(j,k)]), 2*(j==k), 6*x[j]*(j==k))
+ }
>
>
>
> # (3) compute H
> #
>
> z <- rexp(sum(dimx) + 2*sum(dimlam) + 2*sum(dimmu))
>
> n <- sum(dimx)
> m <- sum(dimlam)
> x <- z[1:n]
> lam <- z[(n+1):(n+m)]
> mu <- z[(n+m+1):(n+m+dimmu)]
> w <- z[(n+m+dimmu+1):(n+2*m+2*dimmu)]
>
> resphi <- funCER(z, dimx, dimlam, grobj=grfullob, constr=g, grconstr=grfullg, joint=h, grjoint=grh, dimmu=dimmu, echo=TRUE)
[1] 2 2 3
[1] 1 2 2
[1] 23
Error in funSSR(z[1:(n + m + dimmu)], dimx, dimlam, grobj, arggrobj, constr, :
DLL requires the use of native symbols
Calls: funCER -> funSSR
Execution halted
Running the tests in ‘tests/CER-funCER-Rcode-joint.R’ failed.
Complete output:
> if(!require("GNE"))stop("this test requires package GNE.")
Loading required package: GNE
Loading required package: alabama
Loading required package: numDeriv
Loading required package: nleqslv
Loading required package: BB
Loading required package: SQUAREM
>
>
> # (1) associated objective functions
> #
>
> dimx <- c(2, 2, 3)
>
> #Gr_x_j O_i(x)
> grfullob <- function(x, i, j)
+ {
+ x <- x[1:7]
+ if(i == 1)
+ {
+ grad <- 3*(x - 1:7)^2
+ }
+ if(i == 2)
+ {
+ grad <- 1:7*(x - 1:7)^(0:6)
+ }
+ if(i == 3)
+ {
+ s <- x[5]^2 + x[6]^2 + x[7]^2 - 5
+ grad <- c(1, 0, 1, 0, 4*x[5]*s, 4*x[6]*s, 4*x[7]*s)
+
+ }
+ grad[j]
+ }
>
>
> #Gr_x_k Gr_x_j O_i(x)
> hefullob <- function(x, i, j, k)
+ {
+ x <- x[1:7]
+ if(i == 1)
+ {
+ he <- diag( 6*(x - 1:7) )
+ }
+ if(i == 2)
+ {
+ he <- diag( c(0, 2, 6, 12, 20, 30, 42)*(x - 1:7)^c(0, 0:5) )
+ }
+ if(i == 3)
+ {
+ s <- x[5]^2 + x[6]^2 + x[7]^2
+
+ he <- rbind(rep(0, 7), rep(0, 7), rep(0, 7), rep(0, 7),
+ c(0, 0, 0, 0, 4*s+8*x[5]^2, 8*x[5]*x[6], 8*x[5]*x[7]),
+ c(0, 0, 0, 0, 8*x[5]*x[6], 4*s+8*x[6]^2, 8*x[6]*x[7]),
+ c(0, 0, 0, 0, 8*x[5]*x[7], 8*x[6]*x[7], 4*s+8*x[7]^2) )
+ }
+ he[j,k]
+ }
>
>
> dimmu <- 3
>
> #constraint function h(x)
> h <- function(x)
+ {
+ x <- x[1:7]
+ c(prod(x) - 1, sum(x^2) -2, sum(x^3) -3)
+ }
> grh <- function(x, j)
+ {
+ x <- x[1:7]
+ c(prod(x[-j]), 2*x[j], 3*x[j]^2)
+ }
> heh <- function(x, j, k)
+ {
+ x <- x[1:7]
+ c(prod(x[-c(j,k)]), 2*(j==k), 6*x[j]*(j==k))
+ }
>
>
>
> # (3) compute H
> #
>
> z <- rexp(sum(dimx) + 2*sum(dimmu))
>
> n <- sum(dimx)
> m <- 0
> x <- z[1:n]
> lam <- NULL
> mu <- z[(n+m+1):(n+m+dimmu)]
> w <- z[(n+m+dimmu+1):(n+2*m+2*dimmu)]
>
> resphi <- funCER(z, dimx, dimlam, grobj=grfullob, joint=h, grjoint=grh, dimmu=dimmu, echo=TRUE)
[1] 2 2 3
[1] 0 0 0
[1] 13
Error in funSSR(z[1:(n + m + dimmu)], dimx, dimlam, grobj, arggrobj, constr, :
DLL requires the use of native symbols
Calls: funCER -> funSSR
Execution halted
Running the tests in ‘tests/GNEnseq-examples.R’ failed.
Complete output:
> if(!require("GNE"))stop("this test requires package GNE.")
Loading required package: GNE
Loading required package: alabama
Loading required package: numDeriv
Loading required package: nleqslv
Loading required package: BB
Loading required package: SQUAREM
>
> itermax <- 10
>
> #-------------------------------------------------------------------------------
> # (1) Example 5 of von Facchinei et al. (2007)
> #-------------------------------------------------------------------------------
>
> dimx <- c(1, 1)
> #Gr_x_j O_i(x)
> grobj <- function(x, i, j)
+ {
+ if(i == 1)
+ res <- c(2*(x[1]-1), 0)
+ if(i == 2)
+ res <- c(0, 2*(x[2]-1/2))
+ res[j]
+ }
> #Gr_x_k Gr_x_j O_i(x)
> heobj <- function(x, i, j, k)
+ 2 * (i == j && j == k)
>
> dimlam <- c(1, 1)
> #constraint function g_i(x)
> g <- function(x, i)
+ sum(x[1:2]) - 1
> #Gr_x_j g_i(x)
> grg <- function(x, i, j)
+ 1
> #Gr_x_k Gr_x_j g_i(x)
> heg <- function(x, i, j, k)
+ 0
>
>
>
> #true value is (3/4, 1/4, 1/2, 1/2)
>
> z0 <- rep(0, sum(dimx)+sum(dimlam))
>
> funSSR(z0, dimx, dimlam, grobj=grobj, constr=g, grconstr=grg, compl=phiFB, echo=FALSE)
Error in funSSR(z0, dimx, dimlam, grobj = grobj, constr = g, grconstr = grg, :
DLL requires the use of native symbols
Execution halted
Running the tests in ‘tests/SSR-Rcode-funSSRcheck-constrjoint.R’ failed.
Complete output:
> if(!require("GNE"))stop("this test requires package GNE.")
Loading required package: GNE
Loading required package: alabama
Loading required package: numDeriv
Loading required package: nleqslv
Loading required package: BB
Loading required package: SQUAREM
>
>
> # (1) associated objective functions
> #
>
> dimx <- c(2, 2, 3)
>
> #Gr_x_j O_i(x)
> grfullob <- function(x, i, j)
+ {
+ x <- x[1:7]
+ if(i == 1)
+ {
+ grad <- 3*(x - 1:7)^2
+ }
+ if(i == 2)
+ {
+ grad <- 1:7*(x - 1:7)^(0:6)
+ }
+ if(i == 3)
+ {
+ s <- x[5]^2 + x[6]^2 + x[7]^2 - 5
+ grad <- c(1, 0, 1, 0, 4*x[5]*s, 4*x[6]*s, 4*x[7]*s)
+
+ }
+ grad[j]
+ }
>
>
> #Gr_x_k Gr_x_j O_i(x)
> hefullob <- function(x, i, j, k)
+ {
+ x <- x[1:7]
+ if(i == 1)
+ {
+ he <- diag( 6*(x - 1:7) )
+ }
+ if(i == 2)
+ {
+ he <- diag( c(0, 2, 6, 12, 20, 30, 42)*(x - 1:7)^c(0, 0:5) )
+ }
+ if(i == 3)
+ {
+ s <- x[5]^2 + x[6]^2 + x[7]^2
+
+ he <- rbind(rep(0, 7), rep(0, 7), rep(0, 7), rep(0, 7),
+ c(0, 0, 0, 0, 4*s+8*x[5]^2, 8*x[5]*x[6], 8*x[5]*x[7]),
+ c(0, 0, 0, 0, 8*x[5]*x[6], 4*s+8*x[6]^2, 8*x[6]*x[7]),
+ c(0, 0, 0, 0, 8*x[5]*x[7], 8*x[6]*x[7], 4*s+8*x[7]^2) )
+ }
+ he[j,k]
+ }
>
>
>
> # (2) constraint linked functions
> #
>
> dimlam <- c(1, 2, 2)
>
> #constraint function g_i(x)
> g <- function(x, i)
+ {
+ x <- x[1:7]
+ #cat(x[1:5], "|", i, "\n")
+ if(i == 1)
+ res <- sum( x^(1:7) ) -7
+ if(i == 2)
+ res <- c(sum(x) + prod(x) - 14, 20 - sum(x))
+ if(i == 3)
+ res <- c(sum(x^2) + 1, 100 - sum(x))
+ #cat("res", res + par$a, "\n")
+ res
+ }
>
>
> #Gr_x_j g_i(x)
> grfullg <- function(x, i, j)
+ {
+ x <- x[1:7]
+ if(i == 1)
+ {
+ grad <- (1:7) * x ^ (0:6)
+ }
+ if(i == 2)
+ {
+ grad <- 1 + sapply(1:7, function(i) prod(x[-i]))
+ grad <- cbind(grad, -1)
+ }
+ if(i == 3)
+ {
+ grad <- cbind(2*x, -1)
+ }
+ if(i == 1) res <- grad[j]
+ if(i != 1) res <- grad[j,]
+ as.numeric(res)
+ }
>
>
>
> #Gr_x_k Gr_x_j g_i(x)
> hefullg <- function(x, i, j, k)
+ {
+ x <- x[1:7]
+ if(i == 1)
+ {
+ he1 <- diag( c(0, 2, 6, 12, 20, 30, 42) * x ^ c(0, 0, 1:5) )
+ }
+ if(i == 2)
+ {
+ he1 <- matrix(0, 7, 7)
+ he1[1, -1] <- sapply(2:7, function(i) prod(x[-c(1, i)]))
+ he1[2, -2] <- sapply(c(1, 3:7), function(i) prod(x[-c(2, i)]))
+ he1[3, -3] <- sapply(c(1:2, 4:7), function(i) prod(x[-c(3, i)]))
+ he1[4, -4] <- sapply(c(1:3, 5:7), function(i) prod(x[-c(4, i)]))
+ he1[5, -5] <- sapply(c(1:4, 6:7), function(i) prod(x[-c(5, i)]))
+ he1[6, -6] <- sapply(c(1:5, 7:7), function(i) prod(x[-c(6, i)]))
+ he1[7, -7] <- sapply(1:6, function(i) prod(x[-c(7, i)]))
+ he2 <- matrix(0, 7, 7)
+ }
+ if(i == 3)
+ {
+ he1 <- diag(rep(2, 7))
+ he2 <- matrix(0, 7, 7)
+ }
+ if(i != 1)
+ return( c(he1[j, k], he2[j, k]) )
+ else
+ return( he1[j, k] )
+ }
>
>
>
>
> dimmu <- 3
>
> #constraint function h(x)
> h <- function(x)
+ {
+ x <- x[1:7]
+ c(prod(x) - 1, sum(x^2) -2, sum(x^3) -3)
+ }
> grh <- function(x, j)
+ {
+ x <- x[1:7]
+ c(prod(x[-j]), 2*x[j], 3*x[j]^2)
+ }
> heh <- function(x, j, k)
+ {
+ x <- x[1:7]
+ c(prod(x[-c(j,k)]), 2*(j==k), 6*x[j]*(j==k))
+ }
>
>
>
> # (3) compute Phi
> #
>
> z <- rexp(sum(dimx) + sum(dimlam) + dimmu)
>
> n <- sum(dimx)
> m <- sum(dimlam)
> x <- z[1:n]
> lam <- z[(n+1):(n+m)]
> mu <- z[-(1:(n+m))]
>
> g(z, 1)
[1] 111.5235
> g(z, 2)
[1] -3.020231 9.389554
> g(z, 3)
[1] 23.98399 89.38955
>
> resphi <- funSSR(z, dimx, dimlam, grobj=grfullob, constr=g, grconstr=grfullg, compl=phiFB, joint=h, grjoint=grh, dimmu=dimmu)
Error in funSSR(z, dimx, dimlam, grobj = grfullob, constr = g, grconstr = grfullg, :
DLL requires the use of native symbols
Execution halted
Running the tests in ‘tests/SSR-funSSR-Rcode-constr.R’ failed.
Complete output:
> if(!require("GNE"))stop("this test requires package GNE.")
Loading required package: GNE
Loading required package: alabama
Loading required package: numDeriv
Loading required package: nleqslv
Loading required package: BB
Loading required package: SQUAREM
>
>
> # (1) associated objective functions
> #
>
> dimx <- c(2, 2, 3)
>
> #Gr_x_j O_i(x)
> grfullob <- function(x, i, j)
+ {
+ x <- x[1:7]
+ if(i == 1)
+ {
+ grad <- 3*(x - 1:7)^2
+ }
+ if(i == 2)
+ {
+ grad <- 1:7*(x - 1:7)^(0:6)
+ }
+ if(i == 3)
+ {
+ s <- x[5]^2 + x[6]^2 + x[7]^2 - 5
+ grad <- c(1, 0, 1, 0, 4*x[5]*s, 4*x[6]*s, 4*x[7]*s)
+
+ }
+ grad[j]
+ }
>
>
> #Gr_x_k Gr_x_j O_i(x)
> hefullob <- function(x, i, j, k)
+ {
+ x <- x[1:7]
+ if(i == 1)
+ {
+ he <- diag( 6*(x - 1:7) )
+ }
+ if(i == 2)
+ {
+ he <- diag( c(0, 2, 6, 12, 20, 30, 42)*(x - 1:7)^c(0, 0:5) )
+ }
+ if(i == 3)
+ {
+ s <- x[5]^2 + x[6]^2 + x[7]^2
+
+ he <- rbind(rep(0, 7), rep(0, 7), rep(0, 7), rep(0, 7),
+ c(0, 0, 0, 0, 4*s+8*x[5]^2, 8*x[5]*x[6], 8*x[5]*x[7]),
+ c(0, 0, 0, 0, 8*x[5]*x[6], 4*s+8*x[6]^2, 8*x[6]*x[7]),
+ c(0, 0, 0, 0, 8*x[5]*x[7], 8*x[6]*x[7], 4*s+8*x[7]^2) )
+ }
+ he[j,k]
+ }
>
>
>
> # (2) constraint linked functions
> #
>
> dimlam <- c(1, 2, 2)
>
> #constraint function g_i(x)
> g <- function(x, i)
+ {
+ x <- x[1:7]
+ #cat(x[1:5], "|", i, "\n")
+ if(i == 1)
+ res <- sum( x^(1:7) ) -7
+ if(i == 2)
+ res <- c(sum(x) + prod(x) - 14, 20 - sum(x))
+ if(i == 3)
+ res <- c(sum(x^2) + 1, 100 - sum(x))
+ #cat("res", res + par$a, "\n")
+ res
+ }
>
>
> #Gr_x_j g_i(x)
> grfullg <- function(x, i, j)
+ {
+ x <- x[1:7]
+ if(i == 1)
+ {
+ grad <- (1:7) * x ^ (0:6)
+ }
+ if(i == 2)
+ {
+ grad <- 1 + sapply(1:7, function(i) prod(x[-i]))
+ grad <- cbind(grad, -1)
+ }
+ if(i == 3)
+ {
+ grad <- cbind(2*x, -1)
+ }
+
+
+ if(i == 1)
+ res <- grad[j]
+ if(i != 1)
+ res <- grad[j,]
+ as.numeric(res)
+ }
>
>
>
> #Gr_x_k Gr_x_j g_i(x)
> hefullg <- function(x, i, j, k)
+ {
+ x <- x[1:7]
+ if(i == 1)
+ {
+ he1 <- diag( c(0, 2, 6, 12, 20, 30, 42) * x ^ c(0, 0, 1:5) )
+ }
+ if(i == 2)
+ {
+ he1 <- matrix(0, 7, 7)
+ he1[1, -1] <- sapply(2:7, function(i) prod(x[-c(1, i)]))
+ he1[2, -2] <- sapply(c(1, 3:7), function(i) prod(x[-c(2, i)]))
+ he1[3, -3] <- sapply(c(1:2, 4:7), function(i) prod(x[-c(3, i)]))
+ he1[4, -4] <- sapply(c(1:3, 5:7), function(i) prod(x[-c(4, i)]))
+ he1[5, -5] <- sapply(c(1:4, 6:7), function(i) prod(x[-c(5, i)]))
+ he1[6, -6] <- sapply(c(1:5, 7:7), function(i) prod(x[-c(6, i)]))
+ he1[7, -7] <- sapply(1:6, function(i) prod(x[-c(7, i)]))
+
+
+ he2 <- matrix(0, 7, 7)
+
+ }
+ if(i == 3)
+ {
+ he1 <- diag(rep(2, 7))
+ he2 <- matrix(0, 7, 7)
+ }
+ if(i != 1)
+ return( c(he1[j, k], he2[j, k]) )
+ else
+ return( he1[j, k] )
+ }
>
>
>
>
> # (3) compute Phi
> #
>
> z <- rexp(sum(dimx) + sum(dimlam))
>
> n <- sum(dimx)
> m <- sum(dimlam)
> x <- z[1:n]
> lam <- z[(n+1):(n+m)]
>
> resphi <- funSSR(z, dimx, dimlam, grobj=grfullob, constr=g, grconstr=grfullg, compl=phiFB)
Error in funSSR(z, dimx, dimlam, grobj = grfullob, constr = g, grconstr = grfullg, :
DLL requires the use of native symbols
Execution halted
Running the tests in ‘tests/SSR-funSSR-funSSRcheck-constr.R’ failed.
Complete output:
> if(!require("GNE"))stop("this test requires package GNE.")
Loading required package: GNE
Loading required package: alabama
Loading required package: numDeriv
Loading required package: nleqslv
Loading required package: BB
Loading required package: SQUAREM
>
>
> # (1) associated objective functions
> #
>
> dimx <- c(2, 2, 3)
>
> #Gr_x_j O_i(x)
> grfullob <- function(x, i, j)
+ {
+ x <- x[1:7]
+ if(i == 1)
+ {
+ grad <- 3*(x - 1:7)^2
+ }
+ if(i == 2)
+ {
+ grad <- 1:7*(x - 1:7)^(0:6)
+ }
+ if(i == 3)
+ {
+ s <- x[5]^2 + x[6]^2 + x[7]^2 - 5
+ grad <- c(1, 0, 1, 0, 4*x[5]*s, 4*x[6]*s, 4*x[7]*s)
+
+ }
+ grad[j]
+ }
>
>
> #Gr_x_k Gr_x_j O_i(x)
> hefullob <- function(x, i, j, k)
+ {
+ x <- x[1:7]
+ if(i == 1)
+ {
+ he <- diag( 6*(x - 1:7) )
+ }
+ if(i == 2)
+ {
+ he <- diag( c(0, 2, 6, 12, 20, 30, 42)*(x - 1:7)^c(0, 0:5) )
+ }
+ if(i == 3)
+ {
+ s <- x[5]^2 + x[6]^2 + x[7]^2
+
+ he <- rbind(rep(0, 7), rep(0, 7), rep(0, 7), rep(0, 7),
+ c(0, 0, 0, 0, 4*s+8*x[5]^2, 8*x[5]*x[6], 8*x[5]*x[7]),
+ c(0, 0, 0, 0, 8*x[5]*x[6], 4*s+8*x[6]^2, 8*x[6]*x[7]),
+ c(0, 0, 0, 0, 8*x[5]*x[7], 8*x[6]*x[7], 4*s+8*x[7]^2) )
+ }
+ he[j,k]
+ }
>
>
>
> # (2) constraint linked functions
> #
>
> dimlam <- c(1, 2, 2)
>
> #constraint function g_i(x)
> g <- function(x, i)
+ {
+ x <- x[1:7]
+ #cat(x[1:5], "|", i, "\n")
+ if(i == 1)
+ res <- sum( x^(1:7) ) -7
+ if(i == 2)
+ res <- c(sum(x) + prod(x) - 14, 20 - sum(x))
+ if(i == 3)
+ res <- c(sum(x^2) + 1, 100 - sum(x))
+ #cat("res", res + par$a, "\n")
+ res
+ }
>
>
> #Gr_x_j g_i(x)
> grfullg <- function(x, i, j)
+ {
+ x <- x[1:7]
+ if(i == 1)
+ {
+ grad <- (1:7) * x ^ (0:6)
+ }
+ if(i == 2)
+ {
+ grad <- 1 + sapply(1:7, function(i) prod(x[-i]))
+ grad <- cbind(grad, -1)
+ }
+ if(i == 3)
+ {
+ grad <- cbind(2*x, -1)
+ }
+
+
+ if(i == 1)
+ res <- grad[j]
+ if(i != 1)
+ res <- grad[j,]
+ as.numeric(res)
+ }
>
>
>
> #Gr_x_k Gr_x_j g_i(x)
> hefullg <- function(x, i, j, k)
+ {
+ x <- x[1:7]
+ if(i == 1)
+ {
+ he1 <- diag( c(0, 2, 6, 12, 20, 30, 42) * x ^ c(0, 0, 1:5) )
+ }
+ if(i == 2)
+ {
+ he1 <- matrix(0, 7, 7)
+ he1[1, -1] <- sapply(2:7, function(i) prod(x[-c(1, i)]))
+ he1[2, -2] <- sapply(c(1, 3:7), function(i) prod(x[-c(2, i)]))
+ he1[3, -3] <- sapply(c(1:2, 4:7), function(i) prod(x[-c(3, i)]))
+ he1[4, -4] <- sapply(c(1:3, 5:7), function(i) prod(x[-c(4, i)]))
+ he1[5, -5] <- sapply(c(1:4, 6:7), function(i) prod(x[-c(5, i)]))
+ he1[6, -6] <- sapply(c(1:5, 7:7), function(i) prod(x[-c(6, i)]))
+ he1[7, -7] <- sapply(1:6, function(i) prod(x[-c(7, i)]))
+
+
+ he2 <- matrix(0, 7, 7)
+
+ }
+ if(i == 3)
+ {
+ he1 <- diag(rep(2, 7))
+ he2 <- matrix(0, 7, 7)
+ }
+ if(i != 1)
+ return( c(he1[j, k], he2[j, k]) )
+ else
+ return( he1[j, k] )
+ }
>
>
>
>
> # (3) compute Phi
> #
>
> z <- rexp(sum(dimx) + sum(dimlam))
>
> n <- sum(dimx)
> m <- sum(dimlam)
> x <- z[1:n]
> lam <- z[(n+1):(n+m)]
>
> resphi <- funSSR(z, dimx, dimlam, grobj=grfullob, constr=g, grconstr=grfullg, compl=phiFB)
Error in funSSR(z, dimx, dimlam, grobj = grfullob, constr = g, grconstr = grfullg, :
DLL requires the use of native symbols
Execution halted
Running the tests in ‘tests/SSR-funSSR-funSSRcheck-constrjoint.R’ failed.
Complete output:
> if(!require("GNE"))stop("this test requires package GNE.")
Loading required package: GNE
Loading required package: alabama
Loading required package: numDeriv
Loading required package: nleqslv
Loading required package: BB
Loading required package: SQUAREM
>
>
> # (1) associated objective functions
> #
>
> dimx <- c(2, 2, 3)
>
> #Gr_x_j O_i(x)
> grfullob <- function(x, i, j)
+ {
+ x <- x[1:7]
+ if(i == 1)
+ {
+ grad <- 3*(x - 1:7)^2
+ }
+ if(i == 2)
+ {
+ grad <- 1:7*(x - 1:7)^(0:6)
+ }
+ if(i == 3)
+ {
+ s <- x[5]^2 + x[6]^2 + x[7]^2 - 5
+ grad <- c(1, 0, 1, 0, 4*x[5]*s, 4*x[6]*s, 4*x[7]*s)
+
+ }
+ grad[j]
+ }
>
>
> #Gr_x_k Gr_x_j O_i(x)
> hefullob <- function(x, i, j, k)
+ {
+ x <- x[1:7]
+ if(i == 1)
+ {
+ he <- diag( 6*(x - 1:7) )
+ }
+ if(i == 2)
+ {
+ he <- diag( c(0, 2, 6, 12, 20, 30, 42)*(x - 1:7)^c(0, 0:5) )
+ }
+ if(i == 3)
+ {
+ s <- x[5]^2 + x[6]^2 + x[7]^2
+
+ he <- rbind(rep(0, 7), rep(0, 7), rep(0, 7), rep(0, 7),
+ c(0, 0, 0, 0, 4*s+8*x[5]^2, 8*x[5]*x[6], 8*x[5]*x[7]),
+ c(0, 0, 0, 0, 8*x[5]*x[6], 4*s+8*x[6]^2, 8*x[6]*x[7]),
+ c(0, 0, 0, 0, 8*x[5]*x[7], 8*x[6]*x[7], 4*s+8*x[7]^2) )
+ }
+ he[j,k]
+ }
>
>
>
> # (2) constraint linked functions
> #
>
> dimlam <- c(1, 2, 2)
>
> #constraint function g_i(x)
> g <- function(x, i)
+ {
+ x <- x[1:7]
+ #cat(x[1:5], "|", i, "\n")
+ if(i == 1)
+ res <- sum( x^(1:7) ) -7
+ if(i == 2)
+ res <- c(sum(x) + prod(x) - 14, 20 - sum(x))
+ if(i == 3)
+ res <- c(sum(x^2) + 1, 100 - sum(x))
+ #cat("res", res + par$a, "\n")
+ res
+ }
>
>
> #Gr_x_j g_i(x)
> grfullg <- function(x, i, j)
+ {
+ x <- x[1:7]
+ if(i == 1)
+ {
+ grad <- (1:7) * x ^ (0:6)
+ }
+ if(i == 2)
+ {
+ grad <- 1 + sapply(1:7, function(i) prod(x[-i]))
+ grad <- cbind(grad, -1)
+ }
+ if(i == 3)
+ {
+ grad <- cbind(2*x, -1)
+ }
+ if(i == 1) res <- grad[j]
+ if(i != 1) res <- grad[j,]
+ as.numeric(res)
+ }
>
>
>
> #Gr_x_k Gr_x_j g_i(x)
> hefullg <- function(x, i, j, k)
+ {
+ x <- x[1:7]
+ if(i == 1)
+ {
+ he1 <- diag( c(0, 2, 6, 12, 20, 30, 42) * x ^ c(0, 0, 1:5) )
+ }
+ if(i == 2)
+ {
+ he1 <- matrix(0, 7, 7)
+ he1[1, -1] <- sapply(2:7, function(i) prod(x[-c(1, i)]))
+ he1[2, -2] <- sapply(c(1, 3:7), function(i) prod(x[-c(2, i)]))
+ he1[3, -3] <- sapply(c(1:2, 4:7), function(i) prod(x[-c(3, i)]))
+ he1[4, -4] <- sapply(c(1:3, 5:7), function(i) prod(x[-c(4, i)]))
+ he1[5, -5] <- sapply(c(1:4, 6:7), function(i) prod(x[-c(5, i)]))
+ he1[6, -6] <- sapply(c(1:5, 7:7), function(i) prod(x[-c(6, i)]))
+ he1[7, -7] <- sapply(1:6, function(i) prod(x[-c(7, i)]))
+ he2 <- matrix(0, 7, 7)
+ }
+ if(i == 3)
+ {
+ he1 <- diag(rep(2, 7))
+ he2 <- matrix(0, 7, 7)
+ }
+ if(i != 1)
+ return( c(he1[j, k], he2[j, k]) )
+ else
+ return( he1[j, k] )
+ }
>
>
>
>
> dimmu <- 3
>
> #constraint function h(x)
> h <- function(x)
+ {
+ x <- x[1:7]
+ c(prod(x) - 1, sum(x^2) -2, sum(x^3) -3)
+ }
> grh <- function(x, j)
+ {
+ x <- x[1:7]
+ c(prod(x[-j]), 2*x[j], 3*x[j]^2)
+ }
> heh <- function(x, j, k)
+ {
+ x <- x[1:7]
+ c(prod(x[-c(j,k)]), 2*(j==k), 6*x[j]*(j==k))
+ }
>
>
>
> # (3) compute Phi
> #
>
> z <- rexp(sum(dimx) + sum(dimlam) + dimmu)
>
> n <- sum(dimx)
> m <- sum(dimlam)
> x <- z[1:n]
> lam <- z[(n+1):(n+m)]
> mu <- z[-(1:(n+m))]
>
> resphi <- GNE:::funSSRcheck(z, dimx, dimlam, grobj=grfullob, constr=g, grconstr=grfullg, compl=phiFB, joint=h, grjoint=grh, dimmu=dimmu)
>
>
> check <- c(grfullob(x, 1, 1) + lam[1] * grfullg(x, 1, 1) + mu %*% grh(x, 1),
+ grfullob(x, 1, 2) + lam[1] * grfullg(x, 1, 2) + mu %*% grh(x, 2),
+ grfullob(x, 2, 3) + lam[2:3] %*% grfullg(x, 2, 3) + mu %*% grh(x, 3),
+ grfullob(x, 2, 4) + lam[2:3] %*% grfullg(x, 2, 4) + mu %*% grh(x, 4),
+ grfullob(x, 3, 5) + lam[4:5] %*% grfullg(x, 3, 5) + mu %*% grh(x, 5),
+ grfullob(x, 3, 6) + lam[4:5] %*% grfullg(x, 3, 6) + mu %*% grh(x, 6),
+ grfullob(x, 3, 7) + lam[4:5] %*% grfullg(x, 3, 7) + mu %*% grh(x, 7),
+ phiFB(-g(x, 1), lam[1]),
+ phiFB( -g(x, 2)[1], lam[2]),
+ phiFB( -g(x, 2)[2], lam[3]),
+ phiFB( -g(x, 3)[1], lam[4]),
+ phiFB( -g(x, 3)[2], lam[5]),
+ phiFB( -h(x)[1], mu[1]),
+ phiFB( -h(x)[2], mu[2]),
+ phiFB( -h(x)[3], mu[3]))
>
>
> #check
> cat("\n\n________________________________________\n\n")
________________________________________
>
> #part A
> print(cbind(check, res=as.numeric(resphi))[1:n, ])
check res
[1,] 4.1443754 4.1443754
[2,] 5.2701960 5.2701960
[3,] 15.6108299 15.6108299
[4,] -212.2245786 -212.2245786
[5,] 0.9805729 0.9805729
[6,] 2.8948524 2.8948524
[7,] 10.4253274 10.4253274
> #part B
> print(cbind(check, res=as.numeric(resphi))[(n+1):length(z), ])
check res
[1,] 121.9146274 121.9146274
[2,] -1.2372614 -1.2372614
[3,] 26.2527589 26.2527589
[4,] 15.8212629 15.8212629
[5,] 185.3843714 185.3843714
[6,] -0.6581436 -0.6581436
[7,] 12.7100869 12.7100869
[8,] 17.2134937 17.2134937
>
>
> if(sum(abs(check - resphi)) > .Machine$double.eps^(2/3))
+ stop("wrong result")
>
>
>
> z <- rexp(sum(dimx) + dimmu)
> n <- sum(dimx)
> m <- 0
> x <- z[1:n]
> mu <- z[-(1:(n+m))]
>
> resphi <- GNE:::funSSRcheck(z, dimx, grobj=grfullob, compl=phiFB, joint=h, grjoint=grh, dimmu=dimmu)
>
>
> check <- c(grfullob(x, 1, 1) + mu %*% grh(x, 1),
+ grfullob(x, 1, 2) + mu %*% grh(x, 2),
+ grfullob(x, 2, 3) + mu %*% grh(x, 3),
+ grfullob(x, 2, 4) + mu %*% grh(x, 4),
+ grfullob(x, 3, 5) + mu %*% grh(x, 5),
+ grfullob(x, 3, 6) + mu %*% grh(x, 6),
+ grfullob(x, 3, 7) + mu %*% grh(x, 7),
+ phiFB( -h(x)[1], mu[1]),
+ phiFB( -h(x)[2], mu[2]),
+ phiFB( -h(x)[3], mu[3]))
>
>
> #check
> cat("\n\n________________________________________\n\n")
________________________________________
>
> #part A
> print(cbind(check, res=as.numeric(resphi))[1:n, ])
check res
[1,] 2.600949 2.600949
[2,] 10.914636 10.914636
[3,] 22.816303 22.816303
[4,] -116.390869 -116.390869
[5,] 203.325163 203.325163
[6,] 188.066239 188.066239
[7,] 24.824489 24.824489
> #part B
> print(cbind(check, res=as.numeric(resphi))[(n+1):length(z), ])
check res
[1,] 0.3784036 0.3784036
[2,] 42.1384329 42.1384329
[3,] 119.5852020 119.5852020
>
>
> if(sum(abs(check - resphi)) > .Machine$double.eps^(2/3))
+ stop("wrong result")
>
>
>
>
>
>
>
> # (4) compute Jac Phi
> #
>
> z <- rexp(sum(dimx) + sum(dimlam) + dimmu)
>
> n <- sum(dimx)
> m <- sum(dimlam)
> x <- z[1:n]
> lam <- z[(n+1):(n+m)]
> mu <- z[-(1:(n+m))]
>
>
> resjacphi <- jacSSR(z, dimx, dimlam, heobj=hefullob, constr=g,
+ grconstr=grfullg, heconstr=hefullg, gcompla=GrAphiFB, gcomplb=GrBphiFB,
+ joint=h, grjoint=grh, hejoint=heh, dimmu=dimmu)
Error in jacSSR(z, dimx, dimlam, heobj = hefullob, constr = g, grconstr = grfullg, :
DLL requires the use of native symbols
Execution halted
Running the tests in ‘tests/SSR-testarg.R’ failed.
Complete output:
> if(!require("GNE"))stop("this test requires package GNE.")
Loading required package: GNE
Loading required package: alabama
Loading required package: numDeriv
Loading required package: nleqslv
Loading required package: BB
Loading required package: SQUAREM
>
>
> try(funSSR("x"))
Error in funSSR("x") : argument "dimx" is missing, with no default
>
> try(funSSR(rep(1, 2) , 1, grobj=function(x) x))
Error in testargfunSSR(z, dimx, dimlam, grobj, arggrobj, constr, argconstr, :
SSR: incompatible dimension for dimlam, dimx, dimmu.
>
> try(funSSR(rep(1, 2), rep(1, 2), grobj=function(x) x))
Error in testargfunSSR(z, dimx, dimlam, grobj, arggrobj, constr, argconstr, :
missing compl argument.
>
> try(funSSR(rep(1, 2), rep(1, 2), grobj=function(x) x, compl=phiFB))
Error in grobj(z, i, j) : unused arguments (i, j)
Error when calling function, below the try output.
[1] "Error in grobj(z, i, j) : unused arguments (i, j)\n"
attr(,"class")
[1] "try-error"
attr(,"condition")
<simpleError in grobj(z, i, j): unused arguments (i, j)>
Arguments are:
[[1]]
[1] 1 1
[[2]]
[1] 1
[[3]]
[1] 1
[[4]]
list()
Error in testfunc(grobjfinal, z, arg = arggrobj, echo = echo, errmess = str) :
the call to grobj(z, 1, 1, arggrobj) does not work. arguments are x .
>
> funSSR(rep(1, 2), rep(1, 2), grobj=function(x, i, j) x, compl=phiFB)
Error in funSSR(rep(1, 2), rep(1, 2), grobj = function(x, i, j) x, compl = phiFB) :
DLL requires the use of native symbols
Execution halted
Running the tests in ‘tests/sensi-analysis-riverbasinpollution.R’ failed.
Complete output:
> if(!require("GNE"))stop("this test requires package GNE.")
Loading required package: GNE
Loading required package: alabama
Loading required package: numDeriv
Loading required package: nleqslv
Loading required package: BB
Loading required package: SQUAREM
>
> #-------------------------------------------------------------------------------
> # (3) River basin pollution game of Krawczyk and Stanislav Uryasev (2000)
> #-------------------------------------------------------------------------------
>
> myarg0 <- list(
+ C = cbind(c(.1, .12, .15), c(.01, .05, .01)),
+ U = cbind(c(6.5, 5, 5.5), c(4.583, 6.25, 3.75)),
+ K = c(100, 100),
+ E = c(.5, .25, .75),
+ D = c(3, .01)
+ )
>
>
>
> dimx <- c(1, 1, 1)
> #Gr_x_j O_i(x)
> grobj <- function(x, i, j, arg)
+ {
+ dij <- 1*(i == j)
+ res <- -(-arg$D[2] - arg$C[i, 2]*dij) * x[i]
+ res - (arg$D[1] - arg$D[2]*sum(x[1:3]) - arg$C[i, 1] - arg$C[i, 2]*x[i]) * dij
+ }
> #Gr_x_k Gr_x_j O_i(x)
> heobj <- function(x, i, j, k, arg)
+ {
+ dij <- 1*(i == j)
+ dik <- 1*(i == k)
+
+ arg$D[2] * dik + arg$D[2] * dij + 2 * arg$C[i, 2] * dij * dik
+ }
>
> dimlam <- c(2, 2, 2)
> #g_i(x)
> g <- function(x, i, arg)
+ c(sum(arg$U[, 1] * arg$E * x[1:3]) - arg$K[1],
+ sum(arg$U[, 2] * arg$E * x[1:3]) - arg$K[2],
+ -x[1],
+ -x[2],
+ -x[3])
> #Gr_x_j g_i(x)
> grg <- function(x, i, j, arg)
+ c(arg$U[j, 1] * arg$E[j],
+ arg$U[j, 2] * arg$E[j],
+ -1*(i ==j),
+ -1*(i ==j),
+ -1*(i ==j))
> #Gr_x_k Gr_x_j g_i(x)
> heg <- function(x, i, j, k, arg)
+ c(0, 0, 0, 0, 0)
>
> #true value around (21.146, 16.027, 2.724, 0.574, 0.000)
> z0 <- rep(0, sum(dimx)+sum(dimlam))
>
> getNE <- function(x, control=list(maxit=100, trace=0), check=TRUE)
+ {
+ res <- sapply(1:NROW(x), function(i)
+ {
+ myarg <- list(
+ C = cbind(x[i,paste("C",1:3,sep="")], x[i,paste("C",1:3+3,sep="")]),
+ U = cbind(x[i,paste("U",1:3,sep="")], x[i,paste("U",1:3+3,sep="")]),
+ K = x[i,paste("K",1:2,sep="")],
+ E = x[i,paste("E",1:3,sep="")],
+ D = x[i,paste("D",1:2,sep="")]
+ )
+
+ res <- GNE.nseq(z0, dimx, dimlam, grobj=grobj, myarg, heobj=heobj, myarg,
+ constr=g, myarg, grconstr=grg, myarg, heconstr=heg, myarg,
+ compl=phiFB, gcompla=GrAphiFB, gcomplb=GrBphiFB, method="Newton",
+ control=control)
+
+ if(any(res$par[1:3] < 0) && check)
+ return(rep(NA, 3))
+ else
+ return(res$par[1:3])
+ }
+ )
+ }
>
> n <- 10
> Xinputmatrix <- t(replicate(n, unlist(myarg0) * (1 + rnorm(19, 0, .1))))
> X2inputmatrix <- t(replicate(n, unlist(myarg0) * (1 + rnorm(19, 0, .1))))
>
> Youtputs <- t(getNE(Xinputmatrix))
Error in if (any(res$par[1:3] < 0) && check) return(rep(NA, 3)) else return(res$par[1:3]) :
missing value where TRUE/FALSE needed
Calls: t -> getNE -> sapply -> lapply -> FUN
Execution halted
Flavor: r-devel-linux-x86_64-debian-clang
Version: 0.99-4
Check: re-building of vignette outputs
Result: ERROR
Error(s) in re-building vignettes:
...
--- re-building ‘GNE-howto.Rnw’ using Sweave
Loading required package: alabama
Loading required package: numDeriv
Loading required package: nleqslv
Loading required package: BB
Loading required package: SQUAREM
Error: processing vignette ‘GNE-howto.Rnw’ failed with diagnostics:
chunk 6 (label = singjac)
Error in jacSSR(z0, dimx, dimlam, heobj = heobj, myarg, constr = g, grconstr = grg, :
DLL requires the use of native symbols
--- failed re-building ‘GNE-howto.Rnw’
SUMMARY: processing the following file failed:
‘GNE-howto.Rnw’
Error: Vignette re-building failed.
Execution halted
Flavors: r-devel-linux-x86_64-debian-clang, r-devel-linux-x86_64-debian-gcc, r-patched-linux-x86_64
Version: 0.99-4
Check: tests
Result: ERROR
Running ‘CER-funCER-Rcode-constr.R’ [0s/1s]
Running ‘CER-funCER-Rcode-constrjoint.R’ [0s/1s]
Running ‘CER-funCER-Rcode-joint.R’ [0s/1s]
Running ‘GNEceq-examples.R’ [1s/1s]
Running ‘GNEnseq-examples.R’ [0s/1s]
Running ‘NIR-func-Rcode.R’ [4s/6s]
Running ‘NIRandVIPexample.R’ [1s/2s]
Running ‘SSR-Rcode-funSSRcheck-constrjoint.R’ [0s/1s]
Running ‘SSR-funSSR-Rcode-constr.R’ [0s/1s]
Running ‘SSR-funSSR-funSSRcheck-constr.R’ [0s/1s]
Running ‘SSR-funSSR-funSSRcheck-constrjoint.R’ [1s/1s]
Running ‘SSR-testarg.R’ [0s/1s]
Running ‘complfunc-3Dplot.R’ [1s/1s]
Running ‘complfunc-funcFB.R’ [0s/1s]
Running ‘complfunc-limitgraph.R’ [1s/1s]
Running ‘sensi-analysis-duopoly.R’ [0s/1s]
Running ‘sensi-analysis-genduopoly.R’ [5s/7s]
Running ‘sensi-analysis-riverbasinpollution.R’ [0s/1s]
Running ‘util-testfunc.R’ [0s/1s]
Running the tests in ‘tests/CER-funCER-Rcode-constr.R’ failed.
Complete output:
> if(!require("GNE"))stop("this test requires package GNE.")
Loading required package: GNE
Loading required package: alabama
Loading required package: numDeriv
Loading required package: nleqslv
Loading required package: BB
Loading required package: SQUAREM
>
>
>
> # (1) associated objective functions
> #
>
> dimx <- c(2, 2, 3)
>
> #Gr_x_j O_i(x)
> grfullob <- function(x, i, j)
+ {
+ x <- x[1:7]
+ if(i == 1)
+ {
+ grad <- 3*(x - 1:7)^2
+ }
+ if(i == 2)
+ {
+ grad <- 1:7*(x - 1:7)^(0:6)
+ }
+ if(i == 3)
+ {
+ s <- x[5]^2 + x[6]^2 + x[7]^2 - 5
+ grad <- c(1, 0, 1, 0, 4*x[5]*s, 4*x[6]*s, 4*x[7]*s)
+
+ }
+ grad[j]
+ }
>
>
> #Gr_x_k Gr_x_j O_i(x)
> hefullob <- function(x, i, j, k)
+ {
+ x <- x[1:7]
+ if(i == 1)
+ {
+ he <- diag( 6*(x - 1:7) )
+ }
+ if(i == 2)
+ {
+ he <- diag( c(0, 2, 6, 12, 20, 30, 42)*(x - 1:7)^c(0, 0:5) )
+ }
+ if(i == 3)
+ {
+ s <- x[5]^2 + x[6]^2 + x[7]^2
+
+ he <- rbind(rep(0, 7), rep(0, 7), rep(0, 7), rep(0, 7),
+ c(0, 0, 0, 0, 4*s+8*x[5]^2, 8*x[5]*x[6], 8*x[5]*x[7]),
+ c(0, 0, 0, 0, 8*x[5]*x[6], 4*s+8*x[6]^2, 8*x[6]*x[7]),
+ c(0, 0, 0, 0, 8*x[5]*x[7], 8*x[6]*x[7], 4*s+8*x[7]^2) )
+ }
+ he[j,k]
+ }
>
>
>
> # (2) constraint linked functions
> #
>
> dimlam <- dimw <- c(1, 2, 2)
>
> #constraint function g_i(x)
> g <- function(x, i)
+ {
+ x <- x[1:7]
+ #cat(x[1:5], "|", i, "\n")
+ if(i == 1)
+ res <- sum( x^(1:7) ) -7
+ if(i == 2)
+ res <- c(sum(x) + prod(x) - 14, 20 - sum(x))
+ if(i == 3)
+ res <- c(sum(x^2) + 1, 100 - sum(x))
+ #cat("res", res + par$a, "\n")
+ res
+ }
>
>
> #Gr_x_j g_i(x)
> grfullg <- function(x, i, j)
+ {
+ x <- x[1:7]
+ if(i == 1)
+ {
+ grad <- (1:7) * x ^ (0:6)
+ }
+ if(i == 2)
+ {
+ grad <- 1 + sapply(1:7, function(i) prod(x[-i]))
+ grad <- cbind(grad, -1)
+ }
+ if(i == 3)
+ {
+ grad <- cbind(2*x, -1)
+ }
+
+
+ if(i == 1)
+ res <- grad[j]
+ if(i != 1)
+ res <- grad[j,]
+ as.numeric(res)
+ }
>
>
>
> #Gr_x_k Gr_x_j g_i(x)
> hefullg <- function(x, i, j, k)
+ {
+ x <- x[1:7]
+ if(i == 1)
+ {
+ he1 <- diag( c(0, 2, 6, 12, 20, 30, 42) * x ^ c(0, 0, 1:5) )
+ }
+ if(i == 2)
+ {
+ he1 <- matrix(0, 7, 7)
+ he1[1, -1] <- sapply(2:7, function(i) prod(x[-c(1, i)]))
+ he1[2, -2] <- sapply(c(1, 3:7), function(i) prod(x[-c(2, i)]))
+ he1[3, -3] <- sapply(c(1:2, 4:7), function(i) prod(x[-c(3, i)]))
+ he1[4, -4] <- sapply(c(1:3, 5:7), function(i) prod(x[-c(4, i)]))
+ he1[5, -5] <- sapply(c(1:4, 6:7), function(i) prod(x[-c(5, i)]))
+ he1[6, -6] <- sapply(c(1:5, 7:7), function(i) prod(x[-c(6, i)]))
+ he1[7, -7] <- sapply(1:6, function(i) prod(x[-c(7, i)]))
+
+
+ he2 <- matrix(0, 7, 7)
+
+ }
+ if(i == 3)
+ {
+ he1 <- diag(rep(2, 7))
+ he2 <- matrix(0, 7, 7)
+ }
+ if(i != 1)
+ return( c(he1[j, k], he2[j, k]) )
+ else
+ return( he1[j, k] )
+ }
>
>
>
>
> # (3) compute H
> #
>
> z <- rexp(sum(dimx) + sum(dimlam) + sum(dimw))
>
> n <- sum(dimx)
> m <- sum(dimlam)
> x <- z[1:n]
> lam <- z[(n+1):(n+m)]
> w <- z[(n+m+1):(n+m+m)]
>
> resphi <- funCER(z, dimx, dimlam, grobj=grfullob, constr=g, grconstr=grfullg, echo=TRUE)
[1] 2 2 3
[1] 1 2 2
[1] 17
Error in funSSR(z[1:(n + m + dimmu)], dimx, dimlam, grobj, arggrobj, constr, :
DLL requires the use of native symbols
Calls: funCER -> funSSR
Execution halted
Running the tests in ‘tests/CER-funCER-Rcode-constrjoint.R’ failed.
Complete output:
> if(!require("GNE"))stop("this test requires package GNE.")
Loading required package: GNE
Loading required package: alabama
Loading required package: numDeriv
Loading required package: nleqslv
Loading required package: BB
Loading required package: SQUAREM
>
>
> # (1) associated objective functions
> #
>
> dimx <- c(2, 2, 3)
>
> #Gr_x_j O_i(x)
> grfullob <- function(x, i, j)
+ {
+ x <- x[1:7]
+ if(i == 1)
+ {
+ grad <- 3*(x - 1:7)^2
+ }
+ if(i == 2)
+ {
+ grad <- 1:7*(x - 1:7)^(0:6)
+ }
+ if(i == 3)
+ {
+ s <- x[5]^2 + x[6]^2 + x[7]^2 - 5
+ grad <- c(1, 0, 1, 0, 4*x[5]*s, 4*x[6]*s, 4*x[7]*s)
+
+ }
+ grad[j]
+ }
>
>
> #Gr_x_k Gr_x_j O_i(x)
> hefullob <- function(x, i, j, k)
+ {
+ x <- x[1:7]
+ if(i == 1)
+ {
+ he <- diag( 6*(x - 1:7) )
+ }
+ if(i == 2)
+ {
+ he <- diag( c(0, 2, 6, 12, 20, 30, 42)*(x - 1:7)^c(0, 0:5) )
+ }
+ if(i == 3)
+ {
+ s <- x[5]^2 + x[6]^2 + x[7]^2
+
+ he <- rbind(rep(0, 7), rep(0, 7), rep(0, 7), rep(0, 7),
+ c(0, 0, 0, 0, 4*s+8*x[5]^2, 8*x[5]*x[6], 8*x[5]*x[7]),
+ c(0, 0, 0, 0, 8*x[5]*x[6], 4*s+8*x[6]^2, 8*x[6]*x[7]),
+ c(0, 0, 0, 0, 8*x[5]*x[7], 8*x[6]*x[7], 4*s+8*x[7]^2) )
+ }
+ he[j,k]
+ }
>
>
>
> # (2) constraint linked functions
> #
>
> dimlam <- dimw <- c(1, 2, 2)
>
> #constraint function g_i(x)
> g <- function(x, i)
+ {
+ x <- x[1:7]
+ #cat(x[1:5], "|", i, "\n")
+ if(i == 1)
+ res <- sum( x^(1:7) ) -7
+ if(i == 2)
+ res <- c(sum(x) + prod(x) - 14, 20 - sum(x))
+ if(i == 3)
+ res <- c(sum(x^2) + 1, 100 - sum(x))
+ #cat("res", res + par$a, "\n")
+ res
+ }
>
>
> #Gr_x_j g_i(x)
> grfullg <- function(x, i, j)
+ {
+ x <- x[1:7]
+ if(i == 1)
+ {
+ grad <- (1:7) * x ^ (0:6)
+ }
+ if(i == 2)
+ {
+ grad <- 1 + sapply(1:7, function(i) prod(x[-i]))
+ grad <- cbind(grad, -1)
+ }
+ if(i == 3)
+ {
+ grad <- cbind(2*x, -1)
+ }
+
+
+ if(i == 1)
+ res <- grad[j]
+ if(i != 1)
+ res <- grad[j,]
+ as.numeric(res)
+ }
>
>
>
> #Gr_x_k Gr_x_j g_i(x)
> hefullg <- function(x, i, j, k)
+ {
+ x <- x[1:7]
+ if(i == 1)
+ {
+ he1 <- diag( c(0, 2, 6, 12, 20, 30, 42) * x ^ c(0, 0, 1:5) )
+ }
+ if(i == 2)
+ {
+ he1 <- matrix(0, 7, 7)
+ he1[1, -1] <- sapply(2:7, function(i) prod(x[-c(1, i)]))
+ he1[2, -2] <- sapply(c(1, 3:7), function(i) prod(x[-c(2, i)]))
+ he1[3, -3] <- sapply(c(1:2, 4:7), function(i) prod(x[-c(3, i)]))
+ he1[4, -4] <- sapply(c(1:3, 5:7), function(i) prod(x[-c(4, i)]))
+ he1[5, -5] <- sapply(c(1:4, 6:7), function(i) prod(x[-c(5, i)]))
+ he1[6, -6] <- sapply(c(1:5, 7:7), function(i) prod(x[-c(6, i)]))
+ he1[7, -7] <- sapply(1:6, function(i) prod(x[-c(7, i)]))
+ he2 <- matrix(0, 7, 7)
+ }
+ if(i == 3)
+ {
+ he1 <- diag(rep(2, 7))
+ he2 <- matrix(0, 7, 7)
+ }
+ if(i != 1)
+ return( c(he1[j, k], he2[j, k]) )
+ else
+ return( he1[j, k] )
+ }
>
>
> dimmu <- 3
>
> #constraint function h(x)
> h <- function(x)
+ {
+ x <- x[1:7]
+ c(prod(x) - 1, sum(x^2) -2, sum(x^3) -3)
+ }
> grh <- function(x, j)
+ {
+ x <- x[1:7]
+ c(prod(x[-j]), 2*x[j], 3*x[j]^2)
+ }
> heh <- function(x, j, k)
+ {
+ x <- x[1:7]
+ c(prod(x[-c(j,k)]), 2*(j==k), 6*x[j]*(j==k))
+ }
>
>
>
> # (3) compute H
> #
>
> z <- rexp(sum(dimx) + 2*sum(dimlam) + 2*sum(dimmu))
>
> n <- sum(dimx)
> m <- sum(dimlam)
> x <- z[1:n]
> lam <- z[(n+1):(n+m)]
> mu <- z[(n+m+1):(n+m+dimmu)]
> w <- z[(n+m+dimmu+1):(n+2*m+2*dimmu)]
>
> resphi <- funCER(z, dimx, dimlam, grobj=grfullob, constr=g, grconstr=grfullg, joint=h, grjoint=grh, dimmu=dimmu, echo=TRUE)
[1] 2 2 3
[1] 1 2 2
[1] 23
Error in funSSR(z[1:(n + m + dimmu)], dimx, dimlam, grobj, arggrobj, constr, :
DLL requires the use of native symbols
Calls: funCER -> funSSR
Execution halted
Running the tests in ‘tests/CER-funCER-Rcode-joint.R’ failed.
Complete output:
> if(!require("GNE"))stop("this test requires package GNE.")
Loading required package: GNE
Loading required package: alabama
Loading required package: numDeriv
Loading required package: nleqslv
Loading required package: BB
Loading required package: SQUAREM
>
>
> # (1) associated objective functions
> #
>
> dimx <- c(2, 2, 3)
>
> #Gr_x_j O_i(x)
> grfullob <- function(x, i, j)
+ {
+ x <- x[1:7]
+ if(i == 1)
+ {
+ grad <- 3*(x - 1:7)^2
+ }
+ if(i == 2)
+ {
+ grad <- 1:7*(x - 1:7)^(0:6)
+ }
+ if(i == 3)
+ {
+ s <- x[5]^2 + x[6]^2 + x[7]^2 - 5
+ grad <- c(1, 0, 1, 0, 4*x[5]*s, 4*x[6]*s, 4*x[7]*s)
+
+ }
+ grad[j]
+ }
>
>
> #Gr_x_k Gr_x_j O_i(x)
> hefullob <- function(x, i, j, k)
+ {
+ x <- x[1:7]
+ if(i == 1)
+ {
+ he <- diag( 6*(x - 1:7) )
+ }
+ if(i == 2)
+ {
+ he <- diag( c(0, 2, 6, 12, 20, 30, 42)*(x - 1:7)^c(0, 0:5) )
+ }
+ if(i == 3)
+ {
+ s <- x[5]^2 + x[6]^2 + x[7]^2
+
+ he <- rbind(rep(0, 7), rep(0, 7), rep(0, 7), rep(0, 7),
+ c(0, 0, 0, 0, 4*s+8*x[5]^2, 8*x[5]*x[6], 8*x[5]*x[7]),
+ c(0, 0, 0, 0, 8*x[5]*x[6], 4*s+8*x[6]^2, 8*x[6]*x[7]),
+ c(0, 0, 0, 0, 8*x[5]*x[7], 8*x[6]*x[7], 4*s+8*x[7]^2) )
+ }
+ he[j,k]
+ }
>
>
> dimmu <- 3
>
> #constraint function h(x)
> h <- function(x)
+ {
+ x <- x[1:7]
+ c(prod(x) - 1, sum(x^2) -2, sum(x^3) -3)
+ }
> grh <- function(x, j)
+ {
+ x <- x[1:7]
+ c(prod(x[-j]), 2*x[j], 3*x[j]^2)
+ }
> heh <- function(x, j, k)
+ {
+ x <- x[1:7]
+ c(prod(x[-c(j,k)]), 2*(j==k), 6*x[j]*(j==k))
+ }
>
>
>
> # (3) compute H
> #
>
> z <- rexp(sum(dimx) + 2*sum(dimmu))
>
> n <- sum(dimx)
> m <- 0
> x <- z[1:n]
> lam <- NULL
> mu <- z[(n+m+1):(n+m+dimmu)]
> w <- z[(n+m+dimmu+1):(n+2*m+2*dimmu)]
>
> resphi <- funCER(z, dimx, dimlam, grobj=grfullob, joint=h, grjoint=grh, dimmu=dimmu, echo=TRUE)
[1] 2 2 3
[1] 0 0 0
[1] 13
Error in funSSR(z[1:(n + m + dimmu)], dimx, dimlam, grobj, arggrobj, constr, :
DLL requires the use of native symbols
Calls: funCER -> funSSR
Execution halted
Running the tests in ‘tests/GNEnseq-examples.R’ failed.
Complete output:
> if(!require("GNE"))stop("this test requires package GNE.")
Loading required package: GNE
Loading required package: alabama
Loading required package: numDeriv
Loading required package: nleqslv
Loading required package: BB
Loading required package: SQUAREM
>
> itermax <- 10
>
> #-------------------------------------------------------------------------------
> # (1) Example 5 of von Facchinei et al. (2007)
> #-------------------------------------------------------------------------------
>
> dimx <- c(1, 1)
> #Gr_x_j O_i(x)
> grobj <- function(x, i, j)
+ {
+ if(i == 1)
+ res <- c(2*(x[1]-1), 0)
+ if(i == 2)
+ res <- c(0, 2*(x[2]-1/2))
+ res[j]
+ }
> #Gr_x_k Gr_x_j O_i(x)
> heobj <- function(x, i, j, k)
+ 2 * (i == j && j == k)
>
> dimlam <- c(1, 1)
> #constraint function g_i(x)
> g <- function(x, i)
+ sum(x[1:2]) - 1
> #Gr_x_j g_i(x)
> grg <- function(x, i, j)
+ 1
> #Gr_x_k Gr_x_j g_i(x)
> heg <- function(x, i, j, k)
+ 0
>
>
>
> #true value is (3/4, 1/4, 1/2, 1/2)
>
> z0 <- rep(0, sum(dimx)+sum(dimlam))
>
> funSSR(z0, dimx, dimlam, grobj=grobj, constr=g, grconstr=grg, compl=phiFB, echo=FALSE)
Error in funSSR(z0, dimx, dimlam, grobj = grobj, constr = g, grconstr = grg, :
DLL requires the use of native symbols
Execution halted
Running the tests in ‘tests/SSR-Rcode-funSSRcheck-constrjoint.R’ failed.
Complete output:
> if(!require("GNE"))stop("this test requires package GNE.")
Loading required package: GNE
Loading required package: alabama
Loading required package: numDeriv
Loading required package: nleqslv
Loading required package: BB
Loading required package: SQUAREM
>
>
> # (1) associated objective functions
> #
>
> dimx <- c(2, 2, 3)
>
> #Gr_x_j O_i(x)
> grfullob <- function(x, i, j)
+ {
+ x <- x[1:7]
+ if(i == 1)
+ {
+ grad <- 3*(x - 1:7)^2
+ }
+ if(i == 2)
+ {
+ grad <- 1:7*(x - 1:7)^(0:6)
+ }
+ if(i == 3)
+ {
+ s <- x[5]^2 + x[6]^2 + x[7]^2 - 5
+ grad <- c(1, 0, 1, 0, 4*x[5]*s, 4*x[6]*s, 4*x[7]*s)
+
+ }
+ grad[j]
+ }
>
>
> #Gr_x_k Gr_x_j O_i(x)
> hefullob <- function(x, i, j, k)
+ {
+ x <- x[1:7]
+ if(i == 1)
+ {
+ he <- diag( 6*(x - 1:7) )
+ }
+ if(i == 2)
+ {
+ he <- diag( c(0, 2, 6, 12, 20, 30, 42)*(x - 1:7)^c(0, 0:5) )
+ }
+ if(i == 3)
+ {
+ s <- x[5]^2 + x[6]^2 + x[7]^2
+
+ he <- rbind(rep(0, 7), rep(0, 7), rep(0, 7), rep(0, 7),
+ c(0, 0, 0, 0, 4*s+8*x[5]^2, 8*x[5]*x[6], 8*x[5]*x[7]),
+ c(0, 0, 0, 0, 8*x[5]*x[6], 4*s+8*x[6]^2, 8*x[6]*x[7]),
+ c(0, 0, 0, 0, 8*x[5]*x[7], 8*x[6]*x[7], 4*s+8*x[7]^2) )
+ }
+ he[j,k]
+ }
>
>
>
> # (2) constraint linked functions
> #
>
> dimlam <- c(1, 2, 2)
>
> #constraint function g_i(x)
> g <- function(x, i)
+ {
+ x <- x[1:7]
+ #cat(x[1:5], "|", i, "\n")
+ if(i == 1)
+ res <- sum( x^(1:7) ) -7
+ if(i == 2)
+ res <- c(sum(x) + prod(x) - 14, 20 - sum(x))
+ if(i == 3)
+ res <- c(sum(x^2) + 1, 100 - sum(x))
+ #cat("res", res + par$a, "\n")
+ res
+ }
>
>
> #Gr_x_j g_i(x)
> grfullg <- function(x, i, j)
+ {
+ x <- x[1:7]
+ if(i == 1)
+ {
+ grad <- (1:7) * x ^ (0:6)
+ }
+ if(i == 2)
+ {
+ grad <- 1 + sapply(1:7, function(i) prod(x[-i]))
+ grad <- cbind(grad, -1)
+ }
+ if(i == 3)
+ {
+ grad <- cbind(2*x, -1)
+ }
+ if(i == 1) res <- grad[j]
+ if(i != 1) res <- grad[j,]
+ as.numeric(res)
+ }
>
>
>
> #Gr_x_k Gr_x_j g_i(x)
> hefullg <- function(x, i, j, k)
+ {
+ x <- x[1:7]
+ if(i == 1)
+ {
+ he1 <- diag( c(0, 2, 6, 12, 20, 30, 42) * x ^ c(0, 0, 1:5) )
+ }
+ if(i == 2)
+ {
+ he1 <- matrix(0, 7, 7)
+ he1[1, -1] <- sapply(2:7, function(i) prod(x[-c(1, i)]))
+ he1[2, -2] <- sapply(c(1, 3:7), function(i) prod(x[-c(2, i)]))
+ he1[3, -3] <- sapply(c(1:2, 4:7), function(i) prod(x[-c(3, i)]))
+ he1[4, -4] <- sapply(c(1:3, 5:7), function(i) prod(x[-c(4, i)]))
+ he1[5, -5] <- sapply(c(1:4, 6:7), function(i) prod(x[-c(5, i)]))
+ he1[6, -6] <- sapply(c(1:5, 7:7), function(i) prod(x[-c(6, i)]))
+ he1[7, -7] <- sapply(1:6, function(i) prod(x[-c(7, i)]))
+ he2 <- matrix(0, 7, 7)
+ }
+ if(i == 3)
+ {
+ he1 <- diag(rep(2, 7))
+ he2 <- matrix(0, 7, 7)
+ }
+ if(i != 1)
+ return( c(he1[j, k], he2[j, k]) )
+ else
+ return( he1[j, k] )
+ }
>
>
>
>
> dimmu <- 3
>
> #constraint function h(x)
> h <- function(x)
+ {
+ x <- x[1:7]
+ c(prod(x) - 1, sum(x^2) -2, sum(x^3) -3)
+ }
> grh <- function(x, j)
+ {
+ x <- x[1:7]
+ c(prod(x[-j]), 2*x[j], 3*x[j]^2)
+ }
> heh <- function(x, j, k)
+ {
+ x <- x[1:7]
+ c(prod(x[-c(j,k)]), 2*(j==k), 6*x[j]*(j==k))
+ }
>
>
>
> # (3) compute Phi
> #
>
> z <- rexp(sum(dimx) + sum(dimlam) + dimmu)
>
> n <- sum(dimx)
> m <- sum(dimlam)
> x <- z[1:n]
> lam <- z[(n+1):(n+m)]
> mu <- z[-(1:(n+m))]
>
> g(z, 1)
[1] 3.922292
> g(z, 2)
[1] -6.800669 12.807627
> g(z, 3)
[1] 17.79068 92.80763
>
> resphi <- funSSR(z, dimx, dimlam, grobj=grfullob, constr=g, grconstr=grfullg, compl=phiFB, joint=h, grjoint=grh, dimmu=dimmu)
Error in funSSR(z, dimx, dimlam, grobj = grfullob, constr = g, grconstr = grfullg, :
DLL requires the use of native symbols
Execution halted
Running the tests in ‘tests/SSR-funSSR-Rcode-constr.R’ failed.
Complete output:
> if(!require("GNE"))stop("this test requires package GNE.")
Loading required package: GNE
Loading required package: alabama
Loading required package: numDeriv
Loading required package: nleqslv
Loading required package: BB
Loading required package: SQUAREM
>
>
> # (1) associated objective functions
> #
>
> dimx <- c(2, 2, 3)
>
> #Gr_x_j O_i(x)
> grfullob <- function(x, i, j)
+ {
+ x <- x[1:7]
+ if(i == 1)
+ {
+ grad <- 3*(x - 1:7)^2
+ }
+ if(i == 2)
+ {
+ grad <- 1:7*(x - 1:7)^(0:6)
+ }
+ if(i == 3)
+ {
+ s <- x[5]^2 + x[6]^2 + x[7]^2 - 5
+ grad <- c(1, 0, 1, 0, 4*x[5]*s, 4*x[6]*s, 4*x[7]*s)
+
+ }
+ grad[j]
+ }
>
>
> #Gr_x_k Gr_x_j O_i(x)
> hefullob <- function(x, i, j, k)
+ {
+ x <- x[1:7]
+ if(i == 1)
+ {
+ he <- diag( 6*(x - 1:7) )
+ }
+ if(i == 2)
+ {
+ he <- diag( c(0, 2, 6, 12, 20, 30, 42)*(x - 1:7)^c(0, 0:5) )
+ }
+ if(i == 3)
+ {
+ s <- x[5]^2 + x[6]^2 + x[7]^2
+
+ he <- rbind(rep(0, 7), rep(0, 7), rep(0, 7), rep(0, 7),
+ c(0, 0, 0, 0, 4*s+8*x[5]^2, 8*x[5]*x[6], 8*x[5]*x[7]),
+ c(0, 0, 0, 0, 8*x[5]*x[6], 4*s+8*x[6]^2, 8*x[6]*x[7]),
+ c(0, 0, 0, 0, 8*x[5]*x[7], 8*x[6]*x[7], 4*s+8*x[7]^2) )
+ }
+ he[j,k]
+ }
>
>
>
> # (2) constraint linked functions
> #
>
> dimlam <- c(1, 2, 2)
>
> #constraint function g_i(x)
> g <- function(x, i)
+ {
+ x <- x[1:7]
+ #cat(x[1:5], "|", i, "\n")
+ if(i == 1)
+ res <- sum( x^(1:7) ) -7
+ if(i == 2)
+ res <- c(sum(x) + prod(x) - 14, 20 - sum(x))
+ if(i == 3)
+ res <- c(sum(x^2) + 1, 100 - sum(x))
+ #cat("res", res + par$a, "\n")
+ res
+ }
>
>
> #Gr_x_j g_i(x)
> grfullg <- function(x, i, j)
+ {
+ x <- x[1:7]
+ if(i == 1)
+ {
+ grad <- (1:7) * x ^ (0:6)
+ }
+ if(i == 2)
+ {
+ grad <- 1 + sapply(1:7, function(i) prod(x[-i]))
+ grad <- cbind(grad, -1)
+ }
+ if(i == 3)
+ {
+ grad <- cbind(2*x, -1)
+ }
+
+
+ if(i == 1)
+ res <- grad[j]
+ if(i != 1)
+ res <- grad[j,]
+ as.numeric(res)
+ }
>
>
>
> #Gr_x_k Gr_x_j g_i(x)
> hefullg <- function(x, i, j, k)
+ {
+ x <- x[1:7]
+ if(i == 1)
+ {
+ he1 <- diag( c(0, 2, 6, 12, 20, 30, 42) * x ^ c(0, 0, 1:5) )
+ }
+ if(i == 2)
+ {
+ he1 <- matrix(0, 7, 7)
+ he1[1, -1] <- sapply(2:7, function(i) prod(x[-c(1, i)]))
+ he1[2, -2] <- sapply(c(1, 3:7), function(i) prod(x[-c(2, i)]))
+ he1[3, -3] <- sapply(c(1:2, 4:7), function(i) prod(x[-c(3, i)]))
+ he1[4, -4] <- sapply(c(1:3, 5:7), function(i) prod(x[-c(4, i)]))
+ he1[5, -5] <- sapply(c(1:4, 6:7), function(i) prod(x[-c(5, i)]))
+ he1[6, -6] <- sapply(c(1:5, 7:7), function(i) prod(x[-c(6, i)]))
+ he1[7, -7] <- sapply(1:6, function(i) prod(x[-c(7, i)]))
+
+
+ he2 <- matrix(0, 7, 7)
+
+ }
+ if(i == 3)
+ {
+ he1 <- diag(rep(2, 7))
+ he2 <- matrix(0, 7, 7)
+ }
+ if(i != 1)
+ return( c(he1[j, k], he2[j, k]) )
+ else
+ return( he1[j, k] )
+ }
>
>
>
>
> # (3) compute Phi
> #
>
> z <- rexp(sum(dimx) + sum(dimlam))
>
> n <- sum(dimx)
> m <- sum(dimlam)
> x <- z[1:n]
> lam <- z[(n+1):(n+m)]
>
> resphi <- funSSR(z, dimx, dimlam, grobj=grfullob, constr=g, grconstr=grfullg, compl=phiFB)
Error in funSSR(z, dimx, dimlam, grobj = grfullob, constr = g, grconstr = grfullg, :
DLL requires the use of native symbols
Execution halted
Running the tests in ‘tests/SSR-funSSR-funSSRcheck-constr.R’ failed.
Complete output:
> if(!require("GNE"))stop("this test requires package GNE.")
Loading required package: GNE
Loading required package: alabama
Loading required package: numDeriv
Loading required package: nleqslv
Loading required package: BB
Loading required package: SQUAREM
>
>
> # (1) associated objective functions
> #
>
> dimx <- c(2, 2, 3)
>
> #Gr_x_j O_i(x)
> grfullob <- function(x, i, j)
+ {
+ x <- x[1:7]
+ if(i == 1)
+ {
+ grad <- 3*(x - 1:7)^2
+ }
+ if(i == 2)
+ {
+ grad <- 1:7*(x - 1:7)^(0:6)
+ }
+ if(i == 3)
+ {
+ s <- x[5]^2 + x[6]^2 + x[7]^2 - 5
+ grad <- c(1, 0, 1, 0, 4*x[5]*s, 4*x[6]*s, 4*x[7]*s)
+
+ }
+ grad[j]
+ }
>
>
> #Gr_x_k Gr_x_j O_i(x)
> hefullob <- function(x, i, j, k)
+ {
+ x <- x[1:7]
+ if(i == 1)
+ {
+ he <- diag( 6*(x - 1:7) )
+ }
+ if(i == 2)
+ {
+ he <- diag( c(0, 2, 6, 12, 20, 30, 42)*(x - 1:7)^c(0, 0:5) )
+ }
+ if(i == 3)
+ {
+ s <- x[5]^2 + x[6]^2 + x[7]^2
+
+ he <- rbind(rep(0, 7), rep(0, 7), rep(0, 7), rep(0, 7),
+ c(0, 0, 0, 0, 4*s+8*x[5]^2, 8*x[5]*x[6], 8*x[5]*x[7]),
+ c(0, 0, 0, 0, 8*x[5]*x[6], 4*s+8*x[6]^2, 8*x[6]*x[7]),
+ c(0, 0, 0, 0, 8*x[5]*x[7], 8*x[6]*x[7], 4*s+8*x[7]^2) )
+ }
+ he[j,k]
+ }
>
>
>
> # (2) constraint linked functions
> #
>
> dimlam <- c(1, 2, 2)
>
> #constraint function g_i(x)
> g <- function(x, i)
+ {
+ x <- x[1:7]
+ #cat(x[1:5], "|", i, "\n")
+ if(i == 1)
+ res <- sum( x^(1:7) ) -7
+ if(i == 2)
+ res <- c(sum(x) + prod(x) - 14, 20 - sum(x))
+ if(i == 3)
+ res <- c(sum(x^2) + 1, 100 - sum(x))
+ #cat("res", res + par$a, "\n")
+ res
+ }
>
>
> #Gr_x_j g_i(x)
> grfullg <- function(x, i, j)
+ {
+ x <- x[1:7]
+ if(i == 1)
+ {
+ grad <- (1:7) * x ^ (0:6)
+ }
+ if(i == 2)
+ {
+ grad <- 1 + sapply(1:7, function(i) prod(x[-i]))
+ grad <- cbind(grad, -1)
+ }
+ if(i == 3)
+ {
+ grad <- cbind(2*x, -1)
+ }
+
+
+ if(i == 1)
+ res <- grad[j]
+ if(i != 1)
+ res <- grad[j,]
+ as.numeric(res)
+ }
>
>
>
> #Gr_x_k Gr_x_j g_i(x)
> hefullg <- function(x, i, j, k)
+ {
+ x <- x[1:7]
+ if(i == 1)
+ {
+ he1 <- diag( c(0, 2, 6, 12, 20, 30, 42) * x ^ c(0, 0, 1:5) )
+ }
+ if(i == 2)
+ {
+ he1 <- matrix(0, 7, 7)
+ he1[1, -1] <- sapply(2:7, function(i) prod(x[-c(1, i)]))
+ he1[2, -2] <- sapply(c(1, 3:7), function(i) prod(x[-c(2, i)]))
+ he1[3, -3] <- sapply(c(1:2, 4:7), function(i) prod(x[-c(3, i)]))
+ he1[4, -4] <- sapply(c(1:3, 5:7), function(i) prod(x[-c(4, i)]))
+ he1[5, -5] <- sapply(c(1:4, 6:7), function(i) prod(x[-c(5, i)]))
+ he1[6, -6] <- sapply(c(1:5, 7:7), function(i) prod(x[-c(6, i)]))
+ he1[7, -7] <- sapply(1:6, function(i) prod(x[-c(7, i)]))
+
+
+ he2 <- matrix(0, 7, 7)
+
+ }
+ if(i == 3)
+ {
+ he1 <- diag(rep(2, 7))
+ he2 <- matrix(0, 7, 7)
+ }
+ if(i != 1)
+ return( c(he1[j, k], he2[j, k]) )
+ else
+ return( he1[j, k] )
+ }
>
>
>
>
> # (3) compute Phi
> #
>
> z <- rexp(sum(dimx) + sum(dimlam))
>
> n <- sum(dimx)
> m <- sum(dimlam)
> x <- z[1:n]
> lam <- z[(n+1):(n+m)]
>
> resphi <- funSSR(z, dimx, dimlam, grobj=grfullob, constr=g, grconstr=grfullg, compl=phiFB)
Error in funSSR(z, dimx, dimlam, grobj = grfullob, constr = g, grconstr = grfullg, :
DLL requires the use of native symbols
Execution halted
Running the tests in ‘tests/SSR-funSSR-funSSRcheck-constrjoint.R’ failed.
Complete output:
> if(!require("GNE"))stop("this test requires package GNE.")
Loading required package: GNE
Loading required package: alabama
Loading required package: numDeriv
Loading required package: nleqslv
Loading required package: BB
Loading required package: SQUAREM
>
>
> # (1) associated objective functions
> #
>
> dimx <- c(2, 2, 3)
>
> #Gr_x_j O_i(x)
> grfullob <- function(x, i, j)
+ {
+ x <- x[1:7]
+ if(i == 1)
+ {
+ grad <- 3*(x - 1:7)^2
+ }
+ if(i == 2)
+ {
+ grad <- 1:7*(x - 1:7)^(0:6)
+ }
+ if(i == 3)
+ {
+ s <- x[5]^2 + x[6]^2 + x[7]^2 - 5
+ grad <- c(1, 0, 1, 0, 4*x[5]*s, 4*x[6]*s, 4*x[7]*s)
+
+ }
+ grad[j]
+ }
>
>
> #Gr_x_k Gr_x_j O_i(x)
> hefullob <- function(x, i, j, k)
+ {
+ x <- x[1:7]
+ if(i == 1)
+ {
+ he <- diag( 6*(x - 1:7) )
+ }
+ if(i == 2)
+ {
+ he <- diag( c(0, 2, 6, 12, 20, 30, 42)*(x - 1:7)^c(0, 0:5) )
+ }
+ if(i == 3)
+ {
+ s <- x[5]^2 + x[6]^2 + x[7]^2
+
+ he <- rbind(rep(0, 7), rep(0, 7), rep(0, 7), rep(0, 7),
+ c(0, 0, 0, 0, 4*s+8*x[5]^2, 8*x[5]*x[6], 8*x[5]*x[7]),
+ c(0, 0, 0, 0, 8*x[5]*x[6], 4*s+8*x[6]^2, 8*x[6]*x[7]),
+ c(0, 0, 0, 0, 8*x[5]*x[7], 8*x[6]*x[7], 4*s+8*x[7]^2) )
+ }
+ he[j,k]
+ }
>
>
>
> # (2) constraint linked functions
> #
>
> dimlam <- c(1, 2, 2)
>
> #constraint function g_i(x)
> g <- function(x, i)
+ {
+ x <- x[1:7]
+ #cat(x[1:5], "|", i, "\n")
+ if(i == 1)
+ res <- sum( x^(1:7) ) -7
+ if(i == 2)
+ res <- c(sum(x) + prod(x) - 14, 20 - sum(x))
+ if(i == 3)
+ res <- c(sum(x^2) + 1, 100 - sum(x))
+ #cat("res", res + par$a, "\n")
+ res
+ }
>
>
> #Gr_x_j g_i(x)
> grfullg <- function(x, i, j)
+ {
+ x <- x[1:7]
+ if(i == 1)
+ {
+ grad <- (1:7) * x ^ (0:6)
+ }
+ if(i == 2)
+ {
+ grad <- 1 + sapply(1:7, function(i) prod(x[-i]))
+ grad <- cbind(grad, -1)
+ }
+ if(i == 3)
+ {
+ grad <- cbind(2*x, -1)
+ }
+ if(i == 1) res <- grad[j]
+ if(i != 1) res <- grad[j,]
+ as.numeric(res)
+ }
>
>
>
> #Gr_x_k Gr_x_j g_i(x)
> hefullg <- function(x, i, j, k)
+ {
+ x <- x[1:7]
+ if(i == 1)
+ {
+ he1 <- diag( c(0, 2, 6, 12, 20, 30, 42) * x ^ c(0, 0, 1:5) )
+ }
+ if(i == 2)
+ {
+ he1 <- matrix(0, 7, 7)
+ he1[1, -1] <- sapply(2:7, function(i) prod(x[-c(1, i)]))
+ he1[2, -2] <- sapply(c(1, 3:7), function(i) prod(x[-c(2, i)]))
+ he1[3, -3] <- sapply(c(1:2, 4:7), function(i) prod(x[-c(3, i)]))
+ he1[4, -4] <- sapply(c(1:3, 5:7), function(i) prod(x[-c(4, i)]))
+ he1[5, -5] <- sapply(c(1:4, 6:7), function(i) prod(x[-c(5, i)]))
+ he1[6, -6] <- sapply(c(1:5, 7:7), function(i) prod(x[-c(6, i)]))
+ he1[7, -7] <- sapply(1:6, function(i) prod(x[-c(7, i)]))
+ he2 <- matrix(0, 7, 7)
+ }
+ if(i == 3)
+ {
+ he1 <- diag(rep(2, 7))
+ he2 <- matrix(0, 7, 7)
+ }
+ if(i != 1)
+ return( c(he1[j, k], he2[j, k]) )
+ else
+ return( he1[j, k] )
+ }
>
>
>
>
> dimmu <- 3
>
> #constraint function h(x)
> h <- function(x)
+ {
+ x <- x[1:7]
+ c(prod(x) - 1, sum(x^2) -2, sum(x^3) -3)
+ }
> grh <- function(x, j)
+ {
+ x <- x[1:7]
+ c(prod(x[-j]), 2*x[j], 3*x[j]^2)
+ }
> heh <- function(x, j, k)
+ {
+ x <- x[1:7]
+ c(prod(x[-c(j,k)]), 2*(j==k), 6*x[j]*(j==k))
+ }
>
>
>
> # (3) compute Phi
> #
>
> z <- rexp(sum(dimx) + sum(dimlam) + dimmu)
>
> n <- sum(dimx)
> m <- sum(dimlam)
> x <- z[1:n]
> lam <- z[(n+1):(n+m)]
> mu <- z[-(1:(n+m))]
>
> resphi <- GNE:::funSSRcheck(z, dimx, dimlam, grobj=grfullob, constr=g, grconstr=grfullg, compl=phiFB, joint=h, grjoint=grh, dimmu=dimmu)
>
>
> check <- c(grfullob(x, 1, 1) + lam[1] * grfullg(x, 1, 1) + mu %*% grh(x, 1),
+ grfullob(x, 1, 2) + lam[1] * grfullg(x, 1, 2) + mu %*% grh(x, 2),
+ grfullob(x, 2, 3) + lam[2:3] %*% grfullg(x, 2, 3) + mu %*% grh(x, 3),
+ grfullob(x, 2, 4) + lam[2:3] %*% grfullg(x, 2, 4) + mu %*% grh(x, 4),
+ grfullob(x, 3, 5) + lam[4:5] %*% grfullg(x, 3, 5) + mu %*% grh(x, 5),
+ grfullob(x, 3, 6) + lam[4:5] %*% grfullg(x, 3, 6) + mu %*% grh(x, 6),
+ grfullob(x, 3, 7) + lam[4:5] %*% grfullg(x, 3, 7) + mu %*% grh(x, 7),
+ phiFB(-g(x, 1), lam[1]),
+ phiFB( -g(x, 2)[1], lam[2]),
+ phiFB( -g(x, 2)[2], lam[3]),
+ phiFB( -g(x, 3)[1], lam[4]),
+ phiFB( -g(x, 3)[2], lam[5]),
+ phiFB( -h(x)[1], mu[1]),
+ phiFB( -h(x)[2], mu[2]),
+ phiFB( -h(x)[3], mu[3]))
>
>
> #check
> cat("\n\n________________________________________\n\n")
________________________________________
>
> #part A
> print(cbind(check, res=as.numeric(resphi))[1:n, ])
check res
[1,] 14.922994 14.922994
[2,] 11.976890 11.976890
[3,] 23.929718 23.929718
[4,] -152.489643 -152.489643
[5,] -1.881621 -1.881621
[6,] -1.624014 -1.624014
[7,] 6.340499 6.340499
> #part B
> print(cbind(check, res=as.numeric(resphi))[(n+1):length(z), ])
check res
[1,] 73.3204385 73.3204385
[2,] -0.6009431 -0.6009431
[3,] 28.1518187 28.1518187
[4,] 12.8805374 12.8805374
[5,] 187.3763705 187.3763705
[6,] -0.7479029 -0.7479029
[7,] 4.7925080 4.7925080
[8,] 8.0802381 8.0802381
>
>
> if(sum(abs(check - resphi)) > .Machine$double.eps^(2/3))
+ stop("wrong result")
>
>
>
> z <- rexp(sum(dimx) + dimmu)
> n <- sum(dimx)
> m <- 0
> x <- z[1:n]
> mu <- z[-(1:(n+m))]
>
> resphi <- GNE:::funSSRcheck(z, dimx, grobj=grfullob, compl=phiFB, joint=h, grjoint=grh, dimmu=dimmu)
>
>
> check <- c(grfullob(x, 1, 1) + mu %*% grh(x, 1),
+ grfullob(x, 1, 2) + mu %*% grh(x, 2),
+ grfullob(x, 2, 3) + mu %*% grh(x, 3),
+ grfullob(x, 2, 4) + mu %*% grh(x, 4),
+ grfullob(x, 3, 5) + mu %*% grh(x, 5),
+ grfullob(x, 3, 6) + mu %*% grh(x, 6),
+ grfullob(x, 3, 7) + mu %*% grh(x, 7),
+ phiFB( -h(x)[1], mu[1]),
+ phiFB( -h(x)[2], mu[2]),
+ phiFB( -h(x)[3], mu[3]))
>
>
> #check
> cat("\n\n________________________________________\n\n")
________________________________________
>
> #part A
> print(cbind(check, res=as.numeric(resphi))[1:n, ])
check res
[1,] 2.7919960 2.7919960
[2,] 10.8912000 10.8912000
[3,] 39.8934440 39.8934440
[4,] -78.6819596 -78.6819596
[5,] 0.8435577 0.8435577
[6,] 7.5942524 7.5942524
[7,] -1.3750236 -1.3750236
> #part B
> print(cbind(check, res=as.numeric(resphi))[(n+1):length(z), ])
check res
[1,] -0.276820 -0.276820
[2,] 7.591222 7.591222
[3,] 7.911296 7.911296
>
>
> if(sum(abs(check - resphi)) > .Machine$double.eps^(2/3))
+ stop("wrong result")
>
>
>
>
>
>
>
> # (4) compute Jac Phi
> #
>
> z <- rexp(sum(dimx) + sum(dimlam) + dimmu)
>
> n <- sum(dimx)
> m <- sum(dimlam)
> x <- z[1:n]
> lam <- z[(n+1):(n+m)]
> mu <- z[-(1:(n+m))]
>
>
> resjacphi <- jacSSR(z, dimx, dimlam, heobj=hefullob, constr=g,
+ grconstr=grfullg, heconstr=hefullg, gcompla=GrAphiFB, gcomplb=GrBphiFB,
+ joint=h, grjoint=grh, hejoint=heh, dimmu=dimmu)
Error in jacSSR(z, dimx, dimlam, heobj = hefullob, constr = g, grconstr = grfullg, :
DLL requires the use of native symbols
Execution halted
Running the tests in ‘tests/SSR-testarg.R’ failed.
Complete output:
> if(!require("GNE"))stop("this test requires package GNE.")
Loading required package: GNE
Loading required package: alabama
Loading required package: numDeriv
Loading required package: nleqslv
Loading required package: BB
Loading required package: SQUAREM
>
>
> try(funSSR("x"))
Error in funSSR("x") : argument "dimx" is missing, with no default
>
> try(funSSR(rep(1, 2) , 1, grobj=function(x) x))
Error in testargfunSSR(z, dimx, dimlam, grobj, arggrobj, constr, argconstr, :
SSR: incompatible dimension for dimlam, dimx, dimmu.
>
> try(funSSR(rep(1, 2), rep(1, 2), grobj=function(x) x))
Error in testargfunSSR(z, dimx, dimlam, grobj, arggrobj, constr, argconstr, :
missing compl argument.
>
> try(funSSR(rep(1, 2), rep(1, 2), grobj=function(x) x, compl=phiFB))
Error in grobj(z, i, j) : unused arguments (i, j)
Error when calling function, below the try output.
[1] "Error in grobj(z, i, j) : unused arguments (i, j)\n"
attr(,"class")
[1] "try-error"
attr(,"condition")
<simpleError in grobj(z, i, j): unused arguments (i, j)>
Arguments are:
[[1]]
[1] 1 1
[[2]]
[1] 1
[[3]]
[1] 1
[[4]]
list()
Error in testfunc(grobjfinal, z, arg = arggrobj, echo = echo, errmess = str) :
the call to grobj(z, 1, 1, arggrobj) does not work. arguments are x .
>
> funSSR(rep(1, 2), rep(1, 2), grobj=function(x, i, j) x, compl=phiFB)
Error in funSSR(rep(1, 2), rep(1, 2), grobj = function(x, i, j) x, compl = phiFB) :
DLL requires the use of native symbols
Execution halted
Running the tests in ‘tests/sensi-analysis-riverbasinpollution.R’ failed.
Complete output:
> if(!require("GNE"))stop("this test requires package GNE.")
Loading required package: GNE
Loading required package: alabama
Loading required package: numDeriv
Loading required package: nleqslv
Loading required package: BB
Loading required package: SQUAREM
>
> #-------------------------------------------------------------------------------
> # (3) River basin pollution game of Krawczyk and Stanislav Uryasev (2000)
> #-------------------------------------------------------------------------------
>
> myarg0 <- list(
+ C = cbind(c(.1, .12, .15), c(.01, .05, .01)),
+ U = cbind(c(6.5, 5, 5.5), c(4.583, 6.25, 3.75)),
+ K = c(100, 100),
+ E = c(.5, .25, .75),
+ D = c(3, .01)
+ )
>
>
>
> dimx <- c(1, 1, 1)
> #Gr_x_j O_i(x)
> grobj <- function(x, i, j, arg)
+ {
+ dij <- 1*(i == j)
+ res <- -(-arg$D[2] - arg$C[i, 2]*dij) * x[i]
+ res - (arg$D[1] - arg$D[2]*sum(x[1:3]) - arg$C[i, 1] - arg$C[i, 2]*x[i]) * dij
+ }
> #Gr_x_k Gr_x_j O_i(x)
> heobj <- function(x, i, j, k, arg)
+ {
+ dij <- 1*(i == j)
+ dik <- 1*(i == k)
+
+ arg$D[2] * dik + arg$D[2] * dij + 2 * arg$C[i, 2] * dij * dik
+ }
>
> dimlam <- c(2, 2, 2)
> #g_i(x)
> g <- function(x, i, arg)
+ c(sum(arg$U[, 1] * arg$E * x[1:3]) - arg$K[1],
+ sum(arg$U[, 2] * arg$E * x[1:3]) - arg$K[2],
+ -x[1],
+ -x[2],
+ -x[3])
> #Gr_x_j g_i(x)
> grg <- function(x, i, j, arg)
+ c(arg$U[j, 1] * arg$E[j],
+ arg$U[j, 2] * arg$E[j],
+ -1*(i ==j),
+ -1*(i ==j),
+ -1*(i ==j))
> #Gr_x_k Gr_x_j g_i(x)
> heg <- function(x, i, j, k, arg)
+ c(0, 0, 0, 0, 0)
>
> #true value around (21.146, 16.027, 2.724, 0.574, 0.000)
> z0 <- rep(0, sum(dimx)+sum(dimlam))
>
> getNE <- function(x, control=list(maxit=100, trace=0), check=TRUE)
+ {
+ res <- sapply(1:NROW(x), function(i)
+ {
+ myarg <- list(
+ C = cbind(x[i,paste("C",1:3,sep="")], x[i,paste("C",1:3+3,sep="")]),
+ U = cbind(x[i,paste("U",1:3,sep="")], x[i,paste("U",1:3+3,sep="")]),
+ K = x[i,paste("K",1:2,sep="")],
+ E = x[i,paste("E",1:3,sep="")],
+ D = x[i,paste("D",1:2,sep="")]
+ )
+
+ res <- GNE.nseq(z0, dimx, dimlam, grobj=grobj, myarg, heobj=heobj, myarg,
+ constr=g, myarg, grconstr=grg, myarg, heconstr=heg, myarg,
+ compl=phiFB, gcompla=GrAphiFB, gcomplb=GrBphiFB, method="Newton",
+ control=control)
+
+ if(any(res$par[1:3] < 0) && check)
+ return(rep(NA, 3))
+ else
+ return(res$par[1:3])
+ }
+ )
+ }
>
> n <- 10
> Xinputmatrix <- t(replicate(n, unlist(myarg0) * (1 + rnorm(19, 0, .1))))
> X2inputmatrix <- t(replicate(n, unlist(myarg0) * (1 + rnorm(19, 0, .1))))
>
> Youtputs <- t(getNE(Xinputmatrix))
Error in if (any(res$par[1:3] < 0) && check) return(rep(NA, 3)) else return(res$par[1:3]) :
missing value where TRUE/FALSE needed
Calls: t -> getNE -> sapply -> lapply -> FUN
Execution halted
Flavor: r-devel-linux-x86_64-debian-gcc
Version: 0.99-4
Check: examples
Result: ERROR
Running examples in 'GNE-Ex.R' failed
The error most likely occurred in:
> ### Name: GNE.nseq
> ### Title: Non smooth equation reformulation of the GNE problem.
> ### Aliases: GNE.nseq
> ### Keywords: nonlinear optimize
>
> ### ** Examples
>
>
>
> #-------------------------------------------------------------------------------
> # (1) Example 5 of von Facchinei et al. (2007)
> #-------------------------------------------------------------------------------
>
> dimx <- c(1, 1)
> #Gr_x_j O_i(x)
> grobj <- function(x, i, j)
+ {
+ if(i == 1)
+ res <- c(2*(x[1]-1), 0)
+ if(i == 2)
+ res <- c(0, 2*(x[2]-1/2))
+ res[j]
+ }
> #Gr_x_k Gr_x_j O_i(x)
> heobj <- function(x, i, j, k)
+ 2 * (i == j && j == k)
>
> dimlam <- c(1, 1)
> #constraint function g_i(x)
> g <- function(x, i)
+ sum(x[1:2]) - 1
> #Gr_x_j g_i(x)
> grg <- function(x, i, j)
+ 1
> #Gr_x_k Gr_x_j g_i(x)
> heg <- function(x, i, j, k)
+ 0
>
>
>
> #true value is (3/4, 1/4, 1/2, 1/2)
>
> z0 <- rep(0, sum(dimx)+sum(dimlam))
>
> funSSR(z0, dimx, dimlam, grobj=grobj, constr=g, grconstr=grg, compl=phiFB, echo=FALSE)
Error in funSSR(z0, dimx, dimlam, grobj = grobj, constr = g, grconstr = grg, :
DLL requires the use of native symbols
Execution halted
Flavor: r-devel-windows-x86_64
Version: 0.99-4
Check: tests
Result: ERROR
Running 'CER-funCER-Rcode-constr.R' [1s]
Running 'CER-funCER-Rcode-constrjoint.R' [1s]
Running 'CER-funCER-Rcode-joint.R' [1s]
Running 'GNEceq-examples.R' [1s]
Running 'GNEnseq-examples.R' [1s]
Running 'NIR-func-Rcode.R' [6s]
Running 'NIRandVIPexample.R' [3s]
Running 'SSR-Rcode-funSSRcheck-constrjoint.R' [1s]
Running 'SSR-funSSR-Rcode-constr.R' [1s]
Running 'SSR-funSSR-funSSRcheck-constr.R' [1s]
Running 'SSR-funSSR-funSSRcheck-constrjoint.R' [1s]
Running 'SSR-testarg.R' [1s]
Running 'complfunc-3Dplot.R' [1s]
Running 'complfunc-funcFB.R' [1s]
Running 'complfunc-limitgraph.R' [1s]
Running 'sensi-analysis-duopoly.R' [1s]
Running 'sensi-analysis-genduopoly.R' [7s]
Running 'sensi-analysis-riverbasinpollution.R' [1s]
Running 'util-testfunc.R' [1s]
Running the tests in 'tests/CER-funCER-Rcode-constr.R' failed.
Complete output:
> if(!require("GNE"))stop("this test requires package GNE.")
Loading required package: GNE
Loading required package: alabama
Loading required package: numDeriv
Loading required package: nleqslv
Loading required package: BB
Loading required package: SQUAREM
>
>
>
> # (1) associated objective functions
> #
>
> dimx <- c(2, 2, 3)
>
> #Gr_x_j O_i(x)
> grfullob <- function(x, i, j)
+ {
+ x <- x[1:7]
+ if(i == 1)
+ {
+ grad <- 3*(x - 1:7)^2
+ }
+ if(i == 2)
+ {
+ grad <- 1:7*(x - 1:7)^(0:6)
+ }
+ if(i == 3)
+ {
+ s <- x[5]^2 + x[6]^2 + x[7]^2 - 5
+ grad <- c(1, 0, 1, 0, 4*x[5]*s, 4*x[6]*s, 4*x[7]*s)
+
+ }
+ grad[j]
+ }
>
>
> #Gr_x_k Gr_x_j O_i(x)
> hefullob <- function(x, i, j, k)
+ {
+ x <- x[1:7]
+ if(i == 1)
+ {
+ he <- diag( 6*(x - 1:7) )
+ }
+ if(i == 2)
+ {
+ he <- diag( c(0, 2, 6, 12, 20, 30, 42)*(x - 1:7)^c(0, 0:5) )
+ }
+ if(i == 3)
+ {
+ s <- x[5]^2 + x[6]^2 + x[7]^2
+
+ he <- rbind(rep(0, 7), rep(0, 7), rep(0, 7), rep(0, 7),
+ c(0, 0, 0, 0, 4*s+8*x[5]^2, 8*x[5]*x[6], 8*x[5]*x[7]),
+ c(0, 0, 0, 0, 8*x[5]*x[6], 4*s+8*x[6]^2, 8*x[6]*x[7]),
+ c(0, 0, 0, 0, 8*x[5]*x[7], 8*x[6]*x[7], 4*s+8*x[7]^2) )
+ }
+ he[j,k]
+ }
>
>
>
> # (2) constraint linked functions
> #
>
> dimlam <- dimw <- c(1, 2, 2)
>
> #constraint function g_i(x)
> g <- function(x, i)
+ {
+ x <- x[1:7]
+ #cat(x[1:5], "|", i, "\n")
+ if(i == 1)
+ res <- sum( x^(1:7) ) -7
+ if(i == 2)
+ res <- c(sum(x) + prod(x) - 14, 20 - sum(x))
+ if(i == 3)
+ res <- c(sum(x^2) + 1, 100 - sum(x))
+ #cat("res", res + par$a, "\n")
+ res
+ }
>
>
> #Gr_x_j g_i(x)
> grfullg <- function(x, i, j)
+ {
+ x <- x[1:7]
+ if(i == 1)
+ {
+ grad <- (1:7) * x ^ (0:6)
+ }
+ if(i == 2)
+ {
+ grad <- 1 + sapply(1:7, function(i) prod(x[-i]))
+ grad <- cbind(grad, -1)
+ }
+ if(i == 3)
+ {
+ grad <- cbind(2*x, -1)
+ }
+
+
+ if(i == 1)
+ res <- grad[j]
+ if(i != 1)
+ res <- grad[j,]
+ as.numeric(res)
+ }
>
>
>
> #Gr_x_k Gr_x_j g_i(x)
> hefullg <- function(x, i, j, k)
+ {
+ x <- x[1:7]
+ if(i == 1)
+ {
+ he1 <- diag( c(0, 2, 6, 12, 20, 30, 42) * x ^ c(0, 0, 1:5) )
+ }
+ if(i == 2)
+ {
+ he1 <- matrix(0, 7, 7)
+ he1[1, -1] <- sapply(2:7, function(i) prod(x[-c(1, i)]))
+ he1[2, -2] <- sapply(c(1, 3:7), function(i) prod(x[-c(2, i)]))
+ he1[3, -3] <- sapply(c(1:2, 4:7), function(i) prod(x[-c(3, i)]))
+ he1[4, -4] <- sapply(c(1:3, 5:7), function(i) prod(x[-c(4, i)]))
+ he1[5, -5] <- sapply(c(1:4, 6:7), function(i) prod(x[-c(5, i)]))
+ he1[6, -6] <- sapply(c(1:5, 7:7), function(i) prod(x[-c(6, i)]))
+ he1[7, -7] <- sapply(1:6, function(i) prod(x[-c(7, i)]))
+
+
+ he2 <- matrix(0, 7, 7)
+
+ }
+ if(i == 3)
+ {
+ he1 <- diag(rep(2, 7))
+ he2 <- matrix(0, 7, 7)
+ }
+ if(i != 1)
+ return( c(he1[j, k], he2[j, k]) )
+ else
+ return( he1[j, k] )
+ }
>
>
>
>
> # (3) compute H
> #
>
> z <- rexp(sum(dimx) + sum(dimlam) + sum(dimw))
>
> n <- sum(dimx)
> m <- sum(dimlam)
> x <- z[1:n]
> lam <- z[(n+1):(n+m)]
> w <- z[(n+m+1):(n+m+m)]
>
> resphi <- funCER(z, dimx, dimlam, grobj=grfullob, constr=g, grconstr=grfullg, echo=TRUE)
[1] 2 2 3
[1] 1 2 2
[1] 17
Error in funSSR(z[1:(n + m + dimmu)], dimx, dimlam, grobj, arggrobj, constr, :
DLL requires the use of native symbols
Calls: funCER -> funSSR
Execution halted
Running the tests in 'tests/CER-funCER-Rcode-constrjoint.R' failed.
Complete output:
> if(!require("GNE"))stop("this test requires package GNE.")
Loading required package: GNE
Loading required package: alabama
Loading required package: numDeriv
Loading required package: nleqslv
Loading required package: BB
Loading required package: SQUAREM
>
>
> # (1) associated objective functions
> #
>
> dimx <- c(2, 2, 3)
>
> #Gr_x_j O_i(x)
> grfullob <- function(x, i, j)
+ {
+ x <- x[1:7]
+ if(i == 1)
+ {
+ grad <- 3*(x - 1:7)^2
+ }
+ if(i == 2)
+ {
+ grad <- 1:7*(x - 1:7)^(0:6)
+ }
+ if(i == 3)
+ {
+ s <- x[5]^2 + x[6]^2 + x[7]^2 - 5
+ grad <- c(1, 0, 1, 0, 4*x[5]*s, 4*x[6]*s, 4*x[7]*s)
+
+ }
+ grad[j]
+ }
>
>
> #Gr_x_k Gr_x_j O_i(x)
> hefullob <- function(x, i, j, k)
+ {
+ x <- x[1:7]
+ if(i == 1)
+ {
+ he <- diag( 6*(x - 1:7) )
+ }
+ if(i == 2)
+ {
+ he <- diag( c(0, 2, 6, 12, 20, 30, 42)*(x - 1:7)^c(0, 0:5) )
+ }
+ if(i == 3)
+ {
+ s <- x[5]^2 + x[6]^2 + x[7]^2
+
+ he <- rbind(rep(0, 7), rep(0, 7), rep(0, 7), rep(0, 7),
+ c(0, 0, 0, 0, 4*s+8*x[5]^2, 8*x[5]*x[6], 8*x[5]*x[7]),
+ c(0, 0, 0, 0, 8*x[5]*x[6], 4*s+8*x[6]^2, 8*x[6]*x[7]),
+ c(0, 0, 0, 0, 8*x[5]*x[7], 8*x[6]*x[7], 4*s+8*x[7]^2) )
+ }
+ he[j,k]
+ }
>
>
>
> # (2) constraint linked functions
> #
>
> dimlam <- dimw <- c(1, 2, 2)
>
> #constraint function g_i(x)
> g <- function(x, i)
+ {
+ x <- x[1:7]
+ #cat(x[1:5], "|", i, "\n")
+ if(i == 1)
+ res <- sum( x^(1:7) ) -7
+ if(i == 2)
+ res <- c(sum(x) + prod(x) - 14, 20 - sum(x))
+ if(i == 3)
+ res <- c(sum(x^2) + 1, 100 - sum(x))
+ #cat("res", res + par$a, "\n")
+ res
+ }
>
>
> #Gr_x_j g_i(x)
> grfullg <- function(x, i, j)
+ {
+ x <- x[1:7]
+ if(i == 1)
+ {
+ grad <- (1:7) * x ^ (0:6)
+ }
+ if(i == 2)
+ {
+ grad <- 1 + sapply(1:7, function(i) prod(x[-i]))
+ grad <- cbind(grad, -1)
+ }
+ if(i == 3)
+ {
+ grad <- cbind(2*x, -1)
+ }
+
+
+ if(i == 1)
+ res <- grad[j]
+ if(i != 1)
+ res <- grad[j,]
+ as.numeric(res)
+ }
>
>
>
> #Gr_x_k Gr_x_j g_i(x)
> hefullg <- function(x, i, j, k)
+ {
+ x <- x[1:7]
+ if(i == 1)
+ {
+ he1 <- diag( c(0, 2, 6, 12, 20, 30, 42) * x ^ c(0, 0, 1:5) )
+ }
+ if(i == 2)
+ {
+ he1 <- matrix(0, 7, 7)
+ he1[1, -1] <- sapply(2:7, function(i) prod(x[-c(1, i)]))
+ he1[2, -2] <- sapply(c(1, 3:7), function(i) prod(x[-c(2, i)]))
+ he1[3, -3] <- sapply(c(1:2, 4:7), function(i) prod(x[-c(3, i)]))
+ he1[4, -4] <- sapply(c(1:3, 5:7), function(i) prod(x[-c(4, i)]))
+ he1[5, -5] <- sapply(c(1:4, 6:7), function(i) prod(x[-c(5, i)]))
+ he1[6, -6] <- sapply(c(1:5, 7:7), function(i) prod(x[-c(6, i)]))
+ he1[7, -7] <- sapply(1:6, function(i) prod(x[-c(7, i)]))
+ he2 <- matrix(0, 7, 7)
+ }
+ if(i == 3)
+ {
+ he1 <- diag(rep(2, 7))
+ he2 <- matrix(0, 7, 7)
+ }
+ if(i != 1)
+ return( c(he1[j, k], he2[j, k]) )
+ else
+ return( he1[j, k] )
+ }
>
>
> dimmu <- 3
>
> #constraint function h(x)
> h <- function(x)
+ {
+ x <- x[1:7]
+ c(prod(x) - 1, sum(x^2) -2, sum(x^3) -3)
+ }
> grh <- function(x, j)
+ {
+ x <- x[1:7]
+ c(prod(x[-j]), 2*x[j], 3*x[j]^2)
+ }
> heh <- function(x, j, k)
+ {
+ x <- x[1:7]
+ c(prod(x[-c(j,k)]), 2*(j==k), 6*x[j]*(j==k))
+ }
>
>
>
> # (3) compute H
> #
>
> z <- rexp(sum(dimx) + 2*sum(dimlam) + 2*sum(dimmu))
>
> n <- sum(dimx)
> m <- sum(dimlam)
> x <- z[1:n]
> lam <- z[(n+1):(n+m)]
> mu <- z[(n+m+1):(n+m+dimmu)]
> w <- z[(n+m+dimmu+1):(n+2*m+2*dimmu)]
>
> resphi <- funCER(z, dimx, dimlam, grobj=grfullob, constr=g, grconstr=grfullg, joint=h, grjoint=grh, dimmu=dimmu, echo=TRUE)
[1] 2 2 3
[1] 1 2 2
[1] 23
Error in funSSR(z[1:(n + m + dimmu)], dimx, dimlam, grobj, arggrobj, constr, :
DLL requires the use of native symbols
Calls: funCER -> funSSR
Execution halted
Running the tests in 'tests/CER-funCER-Rcode-joint.R' failed.
Complete output:
> if(!require("GNE"))stop("this test requires package GNE.")
Loading required package: GNE
Loading required package: alabama
Loading required package: numDeriv
Loading required package: nleqslv
Loading required package: BB
Loading required package: SQUAREM
>
>
> # (1) associated objective functions
> #
>
> dimx <- c(2, 2, 3)
>
> #Gr_x_j O_i(x)
> grfullob <- function(x, i, j)
+ {
+ x <- x[1:7]
+ if(i == 1)
+ {
+ grad <- 3*(x - 1:7)^2
+ }
+ if(i == 2)
+ {
+ grad <- 1:7*(x - 1:7)^(0:6)
+ }
+ if(i == 3)
+ {
+ s <- x[5]^2 + x[6]^2 + x[7]^2 - 5
+ grad <- c(1, 0, 1, 0, 4*x[5]*s, 4*x[6]*s, 4*x[7]*s)
+
+ }
+ grad[j]
+ }
>
>
> #Gr_x_k Gr_x_j O_i(x)
> hefullob <- function(x, i, j, k)
+ {
+ x <- x[1:7]
+ if(i == 1)
+ {
+ he <- diag( 6*(x - 1:7) )
+ }
+ if(i == 2)
+ {
+ he <- diag( c(0, 2, 6, 12, 20, 30, 42)*(x - 1:7)^c(0, 0:5) )
+ }
+ if(i == 3)
+ {
+ s <- x[5]^2 + x[6]^2 + x[7]^2
+
+ he <- rbind(rep(0, 7), rep(0, 7), rep(0, 7), rep(0, 7),
+ c(0, 0, 0, 0, 4*s+8*x[5]^2, 8*x[5]*x[6], 8*x[5]*x[7]),
+ c(0, 0, 0, 0, 8*x[5]*x[6], 4*s+8*x[6]^2, 8*x[6]*x[7]),
+ c(0, 0, 0, 0, 8*x[5]*x[7], 8*x[6]*x[7], 4*s+8*x[7]^2) )
+ }
+ he[j,k]
+ }
>
>
> dimmu <- 3
>
> #constraint function h(x)
> h <- function(x)
+ {
+ x <- x[1:7]
+ c(prod(x) - 1, sum(x^2) -2, sum(x^3) -3)
+ }
> grh <- function(x, j)
+ {
+ x <- x[1:7]
+ c(prod(x[-j]), 2*x[j], 3*x[j]^2)
+ }
> heh <- function(x, j, k)
+ {
+ x <- x[1:7]
+ c(prod(x[-c(j,k)]), 2*(j==k), 6*x[j]*(j==k))
+ }
>
>
>
> # (3) compute H
> #
>
> z <- rexp(sum(dimx) + 2*sum(dimmu))
>
> n <- sum(dimx)
> m <- 0
> x <- z[1:n]
> lam <- NULL
> mu <- z[(n+m+1):(n+m+dimmu)]
> w <- z[(n+m+dimmu+1):(n+2*m+2*dimmu)]
>
> resphi <- funCER(z, dimx, dimlam, grobj=grfullob, joint=h, grjoint=grh, dimmu=dimmu, echo=TRUE)
[1] 2 2 3
[1] 0 0 0
[1] 13
Error in funSSR(z[1:(n + m + dimmu)], dimx, dimlam, grobj, arggrobj, constr, :
DLL requires the use of native symbols
Calls: funCER -> funSSR
Execution halted
Running the tests in 'tests/GNEnseq-examples.R' failed.
Complete output:
> if(!require("GNE"))stop("this test requires package GNE.")
Loading required package: GNE
Loading required package: alabama
Loading required package: numDeriv
Loading required package: nleqslv
Loading required package: BB
Loading required package: SQUAREM
>
> itermax <- 10
>
> #-------------------------------------------------------------------------------
> # (1) Example 5 of von Facchinei et al. (2007)
> #-------------------------------------------------------------------------------
>
> dimx <- c(1, 1)
> #Gr_x_j O_i(x)
> grobj <- function(x, i, j)
+ {
+ if(i == 1)
+ res <- c(2*(x[1]-1), 0)
+ if(i == 2)
+ res <- c(0, 2*(x[2]-1/2))
+ res[j]
+ }
> #Gr_x_k Gr_x_j O_i(x)
> heobj <- function(x, i, j, k)
+ 2 * (i == j && j == k)
>
> dimlam <- c(1, 1)
> #constraint function g_i(x)
> g <- function(x, i)
+ sum(x[1:2]) - 1
> #Gr_x_j g_i(x)
> grg <- function(x, i, j)
+ 1
> #Gr_x_k Gr_x_j g_i(x)
> heg <- function(x, i, j, k)
+ 0
>
>
>
> #true value is (3/4, 1/4, 1/2, 1/2)
>
> z0 <- rep(0, sum(dimx)+sum(dimlam))
>
> funSSR(z0, dimx, dimlam, grobj=grobj, constr=g, grconstr=grg, compl=phiFB, echo=FALSE)
Error in funSSR(z0, dimx, dimlam, grobj = grobj, constr = g, grconstr = grg, :
DLL requires the use of native symbols
Execution halted
Running the tests in 'tests/SSR-Rcode-funSSRcheck-constrjoint.R' failed.
Complete output:
> if(!require("GNE"))stop("this test requires package GNE.")
Loading required package: GNE
Loading required package: alabama
Loading required package: numDeriv
Loading required package: nleqslv
Loading required package: BB
Loading required package: SQUAREM
>
>
> # (1) associated objective functions
> #
>
> dimx <- c(2, 2, 3)
>
> #Gr_x_j O_i(x)
> grfullob <- function(x, i, j)
+ {
+ x <- x[1:7]
+ if(i == 1)
+ {
+ grad <- 3*(x - 1:7)^2
+ }
+ if(i == 2)
+ {
+ grad <- 1:7*(x - 1:7)^(0:6)
+ }
+ if(i == 3)
+ {
+ s <- x[5]^2 + x[6]^2 + x[7]^2 - 5
+ grad <- c(1, 0, 1, 0, 4*x[5]*s, 4*x[6]*s, 4*x[7]*s)
+
+ }
+ grad[j]
+ }
>
>
> #Gr_x_k Gr_x_j O_i(x)
> hefullob <- function(x, i, j, k)
+ {
+ x <- x[1:7]
+ if(i == 1)
+ {
+ he <- diag( 6*(x - 1:7) )
+ }
+ if(i == 2)
+ {
+ he <- diag( c(0, 2, 6, 12, 20, 30, 42)*(x - 1:7)^c(0, 0:5) )
+ }
+ if(i == 3)
+ {
+ s <- x[5]^2 + x[6]^2 + x[7]^2
+
+ he <- rbind(rep(0, 7), rep(0, 7), rep(0, 7), rep(0, 7),
+ c(0, 0, 0, 0, 4*s+8*x[5]^2, 8*x[5]*x[6], 8*x[5]*x[7]),
+ c(0, 0, 0, 0, 8*x[5]*x[6], 4*s+8*x[6]^2, 8*x[6]*x[7]),
+ c(0, 0, 0, 0, 8*x[5]*x[7], 8*x[6]*x[7], 4*s+8*x[7]^2) )
+ }
+ he[j,k]
+ }
>
>
>
> # (2) constraint linked functions
> #
>
> dimlam <- c(1, 2, 2)
>
> #constraint function g_i(x)
> g <- function(x, i)
+ {
+ x <- x[1:7]
+ #cat(x[1:5], "|", i, "\n")
+ if(i == 1)
+ res <- sum( x^(1:7) ) -7
+ if(i == 2)
+ res <- c(sum(x) + prod(x) - 14, 20 - sum(x))
+ if(i == 3)
+ res <- c(sum(x^2) + 1, 100 - sum(x))
+ #cat("res", res + par$a, "\n")
+ res
+ }
>
>
> #Gr_x_j g_i(x)
> grfullg <- function(x, i, j)
+ {
+ x <- x[1:7]
+ if(i == 1)
+ {
+ grad <- (1:7) * x ^ (0:6)
+ }
+ if(i == 2)
+ {
+ grad <- 1 + sapply(1:7, function(i) prod(x[-i]))
+ grad <- cbind(grad, -1)
+ }
+ if(i == 3)
+ {
+ grad <- cbind(2*x, -1)
+ }
+ if(i == 1) res <- grad[j]
+ if(i != 1) res <- grad[j,]
+ as.numeric(res)
+ }
>
>
>
> #Gr_x_k Gr_x_j g_i(x)
> hefullg <- function(x, i, j, k)
+ {
+ x <- x[1:7]
+ if(i == 1)
+ {
+ he1 <- diag( c(0, 2, 6, 12, 20, 30, 42) * x ^ c(0, 0, 1:5) )
+ }
+ if(i == 2)
+ {
+ he1 <- matrix(0, 7, 7)
+ he1[1, -1] <- sapply(2:7, function(i) prod(x[-c(1, i)]))
+ he1[2, -2] <- sapply(c(1, 3:7), function(i) prod(x[-c(2, i)]))
+ he1[3, -3] <- sapply(c(1:2, 4:7), function(i) prod(x[-c(3, i)]))
+ he1[4, -4] <- sapply(c(1:3, 5:7), function(i) prod(x[-c(4, i)]))
+ he1[5, -5] <- sapply(c(1:4, 6:7), function(i) prod(x[-c(5, i)]))
+ he1[6, -6] <- sapply(c(1:5, 7:7), function(i) prod(x[-c(6, i)]))
+ he1[7, -7] <- sapply(1:6, function(i) prod(x[-c(7, i)]))
+ he2 <- matrix(0, 7, 7)
+ }
+ if(i == 3)
+ {
+ he1 <- diag(rep(2, 7))
+ he2 <- matrix(0, 7, 7)
+ }
+ if(i != 1)
+ return( c(he1[j, k], he2[j, k]) )
+ else
+ return( he1[j, k] )
+ }
>
>
>
>
> dimmu <- 3
>
> #constraint function h(x)
> h <- function(x)
+ {
+ x <- x[1:7]
+ c(prod(x) - 1, sum(x^2) -2, sum(x^3) -3)
+ }
> grh <- function(x, j)
+ {
+ x <- x[1:7]
+ c(prod(x[-j]), 2*x[j], 3*x[j]^2)
+ }
> heh <- function(x, j, k)
+ {
+ x <- x[1:7]
+ c(prod(x[-c(j,k)]), 2*(j==k), 6*x[j]*(j==k))
+ }
>
>
>
> # (3) compute Phi
> #
>
> z <- rexp(sum(dimx) + sum(dimlam) + dimmu)
>
> n <- sum(dimx)
> m <- sum(dimlam)
> x <- z[1:n]
> lam <- z[(n+1):(n+m)]
> mu <- z[-(1:(n+m))]
>
> g(z, 1)
[1] 6929.643
> g(z, 2)
[1] 4.476365 7.691496
> g(z, 3)
[1] 33.50112 87.69150
>
> resphi <- funSSR(z, dimx, dimlam, grobj=grfullob, constr=g, grconstr=grfullg, compl=phiFB, joint=h, grjoint=grh, dimmu=dimmu)
Error in funSSR(z, dimx, dimlam, grobj = grfullob, constr = g, grconstr = grfullg, :
DLL requires the use of native symbols
Execution halted
Running the tests in 'tests/SSR-funSSR-Rcode-constr.R' failed.
Complete output:
> if(!require("GNE"))stop("this test requires package GNE.")
Loading required package: GNE
Loading required package: alabama
Loading required package: numDeriv
Loading required package: nleqslv
Loading required package: BB
Loading required package: SQUAREM
>
>
> # (1) associated objective functions
> #
>
> dimx <- c(2, 2, 3)
>
> #Gr_x_j O_i(x)
> grfullob <- function(x, i, j)
+ {
+ x <- x[1:7]
+ if(i == 1)
+ {
+ grad <- 3*(x - 1:7)^2
+ }
+ if(i == 2)
+ {
+ grad <- 1:7*(x - 1:7)^(0:6)
+ }
+ if(i == 3)
+ {
+ s <- x[5]^2 + x[6]^2 + x[7]^2 - 5
+ grad <- c(1, 0, 1, 0, 4*x[5]*s, 4*x[6]*s, 4*x[7]*s)
+
+ }
+ grad[j]
+ }
>
>
> #Gr_x_k Gr_x_j O_i(x)
> hefullob <- function(x, i, j, k)
+ {
+ x <- x[1:7]
+ if(i == 1)
+ {
+ he <- diag( 6*(x - 1:7) )
+ }
+ if(i == 2)
+ {
+ he <- diag( c(0, 2, 6, 12, 20, 30, 42)*(x - 1:7)^c(0, 0:5) )
+ }
+ if(i == 3)
+ {
+ s <- x[5]^2 + x[6]^2 + x[7]^2
+
+ he <- rbind(rep(0, 7), rep(0, 7), rep(0, 7), rep(0, 7),
+ c(0, 0, 0, 0, 4*s+8*x[5]^2, 8*x[5]*x[6], 8*x[5]*x[7]),
+ c(0, 0, 0, 0, 8*x[5]*x[6], 4*s+8*x[6]^2, 8*x[6]*x[7]),
+ c(0, 0, 0, 0, 8*x[5]*x[7], 8*x[6]*x[7], 4*s+8*x[7]^2) )
+ }
+ he[j,k]
+ }
>
>
>
> # (2) constraint linked functions
> #
>
> dimlam <- c(1, 2, 2)
>
> #constraint function g_i(x)
> g <- function(x, i)
+ {
+ x <- x[1:7]
+ #cat(x[1:5], "|", i, "\n")
+ if(i == 1)
+ res <- sum( x^(1:7) ) -7
+ if(i == 2)
+ res <- c(sum(x) + prod(x) - 14, 20 - sum(x))
+ if(i == 3)
+ res <- c(sum(x^2) + 1, 100 - sum(x))
+ #cat("res", res + par$a, "\n")
+ res
+ }
>
>
> #Gr_x_j g_i(x)
> grfullg <- function(x, i, j)
+ {
+ x <- x[1:7]
+ if(i == 1)
+ {
+ grad <- (1:7) * x ^ (0:6)
+ }
+ if(i == 2)
+ {
+ grad <- 1 + sapply(1:7, function(i) prod(x[-i]))
+ grad <- cbind(grad, -1)
+ }
+ if(i == 3)
+ {
+ grad <- cbind(2*x, -1)
+ }
+
+
+ if(i == 1)
+ res <- grad[j]
+ if(i != 1)
+ res <- grad[j,]
+ as.numeric(res)
+ }
>
>
>
> #Gr_x_k Gr_x_j g_i(x)
> hefullg <- function(x, i, j, k)
+ {
+ x <- x[1:7]
+ if(i == 1)
+ {
+ he1 <- diag( c(0, 2, 6, 12, 20, 30, 42) * x ^ c(0, 0, 1:5) )
+ }
+ if(i == 2)
+ {
+ he1 <- matrix(0, 7, 7)
+ he1[1, -1] <- sapply(2:7, function(i) prod(x[-c(1, i)]))
+ he1[2, -2] <- sapply(c(1, 3:7), function(i) prod(x[-c(2, i)]))
+ he1[3, -3] <- sapply(c(1:2, 4:7), function(i) prod(x[-c(3, i)]))
+ he1[4, -4] <- sapply(c(1:3, 5:7), function(i) prod(x[-c(4, i)]))
+ he1[5, -5] <- sapply(c(1:4, 6:7), function(i) prod(x[-c(5, i)]))
+ he1[6, -6] <- sapply(c(1:5, 7:7), function(i) prod(x[-c(6, i)]))
+ he1[7, -7] <- sapply(1:6, function(i) prod(x[-c(7, i)]))
+
+
+ he2 <- matrix(0, 7, 7)
+
+ }
+ if(i == 3)
+ {
+ he1 <- diag(rep(2, 7))
+ he2 <- matrix(0, 7, 7)
+ }
+ if(i != 1)
+ return( c(he1[j, k], he2[j, k]) )
+ else
+ return( he1[j, k] )
+ }
>
>
>
>
> # (3) compute Phi
> #
>
> z <- rexp(sum(dimx) + sum(dimlam))
>
> n <- sum(dimx)
> m <- sum(dimlam)
> x <- z[1:n]
> lam <- z[(n+1):(n+m)]
>
> resphi <- funSSR(z, dimx, dimlam, grobj=grfullob, constr=g, grconstr=grfullg, compl=phiFB)
Error in funSSR(z, dimx, dimlam, grobj = grfullob, constr = g, grconstr = grfullg, :
DLL requires the use of native symbols
Execution halted
Running the tests in 'tests/SSR-funSSR-funSSRcheck-constr.R' failed.
Complete output:
> if(!require("GNE"))stop("this test requires package GNE.")
Loading required package: GNE
Loading required package: alabama
Loading required package: numDeriv
Loading required package: nleqslv
Loading required package: BB
Loading required package: SQUAREM
>
>
> # (1) associated objective functions
> #
>
> dimx <- c(2, 2, 3)
>
> #Gr_x_j O_i(x)
> grfullob <- function(x, i, j)
+ {
+ x <- x[1:7]
+ if(i == 1)
+ {
+ grad <- 3*(x - 1:7)^2
+ }
+ if(i == 2)
+ {
+ grad <- 1:7*(x - 1:7)^(0:6)
+ }
+ if(i == 3)
+ {
+ s <- x[5]^2 + x[6]^2 + x[7]^2 - 5
+ grad <- c(1, 0, 1, 0, 4*x[5]*s, 4*x[6]*s, 4*x[7]*s)
+
+ }
+ grad[j]
+ }
>
>
> #Gr_x_k Gr_x_j O_i(x)
> hefullob <- function(x, i, j, k)
+ {
+ x <- x[1:7]
+ if(i == 1)
+ {
+ he <- diag( 6*(x - 1:7) )
+ }
+ if(i == 2)
+ {
+ he <- diag( c(0, 2, 6, 12, 20, 30, 42)*(x - 1:7)^c(0, 0:5) )
+ }
+ if(i == 3)
+ {
+ s <- x[5]^2 + x[6]^2 + x[7]^2
+
+ he <- rbind(rep(0, 7), rep(0, 7), rep(0, 7), rep(0, 7),
+ c(0, 0, 0, 0, 4*s+8*x[5]^2, 8*x[5]*x[6], 8*x[5]*x[7]),
+ c(0, 0, 0, 0, 8*x[5]*x[6], 4*s+8*x[6]^2, 8*x[6]*x[7]),
+ c(0, 0, 0, 0, 8*x[5]*x[7], 8*x[6]*x[7], 4*s+8*x[7]^2) )
+ }
+ he[j,k]
+ }
>
>
>
> # (2) constraint linked functions
> #
>
> dimlam <- c(1, 2, 2)
>
> #constraint function g_i(x)
> g <- function(x, i)
+ {
+ x <- x[1:7]
+ #cat(x[1:5], "|", i, "\n")
+ if(i == 1)
+ res <- sum( x^(1:7) ) -7
+ if(i == 2)
+ res <- c(sum(x) + prod(x) - 14, 20 - sum(x))
+ if(i == 3)
+ res <- c(sum(x^2) + 1, 100 - sum(x))
+ #cat("res", res + par$a, "\n")
+ res
+ }
>
>
> #Gr_x_j g_i(x)
> grfullg <- function(x, i, j)
+ {
+ x <- x[1:7]
+ if(i == 1)
+ {
+ grad <- (1:7) * x ^ (0:6)
+ }
+ if(i == 2)
+ {
+ grad <- 1 + sapply(1:7, function(i) prod(x[-i]))
+ grad <- cbind(grad, -1)
+ }
+ if(i == 3)
+ {
+ grad <- cbind(2*x, -1)
+ }
+
+
+ if(i == 1)
+ res <- grad[j]
+ if(i != 1)
+ res <- grad[j,]
+ as.numeric(res)
+ }
>
>
>
> #Gr_x_k Gr_x_j g_i(x)
> hefullg <- function(x, i, j, k)
+ {
+ x <- x[1:7]
+ if(i == 1)
+ {
+ he1 <- diag( c(0, 2, 6, 12, 20, 30, 42) * x ^ c(0, 0, 1:5) )
+ }
+ if(i == 2)
+ {
+ he1 <- matrix(0, 7, 7)
+ he1[1, -1] <- sapply(2:7, function(i) prod(x[-c(1, i)]))
+ he1[2, -2] <- sapply(c(1, 3:7), function(i) prod(x[-c(2, i)]))
+ he1[3, -3] <- sapply(c(1:2, 4:7), function(i) prod(x[-c(3, i)]))
+ he1[4, -4] <- sapply(c(1:3, 5:7), function(i) prod(x[-c(4, i)]))
+ he1[5, -5] <- sapply(c(1:4, 6:7), function(i) prod(x[-c(5, i)]))
+ he1[6, -6] <- sapply(c(1:5, 7:7), function(i) prod(x[-c(6, i)]))
+ he1[7, -7] <- sapply(1:6, function(i) prod(x[-c(7, i)]))
+
+
+ he2 <- matrix(0, 7, 7)
+
+ }
+ if(i == 3)
+ {
+ he1 <- diag(rep(2, 7))
+ he2 <- matrix(0, 7, 7)
+ }
+ if(i != 1)
+ return( c(he1[j, k], he2[j, k]) )
+ else
+ return( he1[j, k] )
+ }
>
>
>
>
> # (3) compute Phi
> #
>
> z <- rexp(sum(dimx) + sum(dimlam))
>
> n <- sum(dimx)
> m <- sum(dimlam)
> x <- z[1:n]
> lam <- z[(n+1):(n+m)]
>
> resphi <- funSSR(z, dimx, dimlam, grobj=grfullob, constr=g, grconstr=grfullg, compl=phiFB)
Error in funSSR(z, dimx, dimlam, grobj = grfullob, constr = g, grconstr = grfullg, :
DLL requires the use of native symbols
Execution halted
Running the tests in 'tests/SSR-funSSR-funSSRcheck-constrjoint.R' failed.
Complete output:
> if(!require("GNE"))stop("this test requires package GNE.")
Loading required package: GNE
Loading required package: alabama
Loading required package: numDeriv
Loading required package: nleqslv
Loading required package: BB
Loading required package: SQUAREM
>
>
> # (1) associated objective functions
> #
>
> dimx <- c(2, 2, 3)
>
> #Gr_x_j O_i(x)
> grfullob <- function(x, i, j)
+ {
+ x <- x[1:7]
+ if(i == 1)
+ {
+ grad <- 3*(x - 1:7)^2
+ }
+ if(i == 2)
+ {
+ grad <- 1:7*(x - 1:7)^(0:6)
+ }
+ if(i == 3)
+ {
+ s <- x[5]^2 + x[6]^2 + x[7]^2 - 5
+ grad <- c(1, 0, 1, 0, 4*x[5]*s, 4*x[6]*s, 4*x[7]*s)
+
+ }
+ grad[j]
+ }
>
>
> #Gr_x_k Gr_x_j O_i(x)
> hefullob <- function(x, i, j, k)
+ {
+ x <- x[1:7]
+ if(i == 1)
+ {
+ he <- diag( 6*(x - 1:7) )
+ }
+ if(i == 2)
+ {
+ he <- diag( c(0, 2, 6, 12, 20, 30, 42)*(x - 1:7)^c(0, 0:5) )
+ }
+ if(i == 3)
+ {
+ s <- x[5]^2 + x[6]^2 + x[7]^2
+
+ he <- rbind(rep(0, 7), rep(0, 7), rep(0, 7), rep(0, 7),
+ c(0, 0, 0, 0, 4*s+8*x[5]^2, 8*x[5]*x[6], 8*x[5]*x[7]),
+ c(0, 0, 0, 0, 8*x[5]*x[6], 4*s+8*x[6]^2, 8*x[6]*x[7]),
+ c(0, 0, 0, 0, 8*x[5]*x[7], 8*x[6]*x[7], 4*s+8*x[7]^2) )
+ }
+ he[j,k]
+ }
>
>
>
> # (2) constraint linked functions
> #
>
> dimlam <- c(1, 2, 2)
>
> #constraint function g_i(x)
> g <- function(x, i)
+ {
+ x <- x[1:7]
+ #cat(x[1:5], "|", i, "\n")
+ if(i == 1)
+ res <- sum( x^(1:7) ) -7
+ if(i == 2)
+ res <- c(sum(x) + prod(x) - 14, 20 - sum(x))
+ if(i == 3)
+ res <- c(sum(x^2) + 1, 100 - sum(x))
+ #cat("res", res + par$a, "\n")
+ res
+ }
>
>
> #Gr_x_j g_i(x)
> grfullg <- function(x, i, j)
+ {
+ x <- x[1:7]
+ if(i == 1)
+ {
+ grad <- (1:7) * x ^ (0:6)
+ }
+ if(i == 2)
+ {
+ grad <- 1 + sapply(1:7, function(i) prod(x[-i]))
+ grad <- cbind(grad, -1)
+ }
+ if(i == 3)
+ {
+ grad <- cbind(2*x, -1)
+ }
+ if(i == 1) res <- grad[j]
+ if(i != 1) res <- grad[j,]
+ as.numeric(res)
+ }
>
>
>
> #Gr_x_k Gr_x_j g_i(x)
> hefullg <- function(x, i, j, k)
+ {
+ x <- x[1:7]
+ if(i == 1)
+ {
+ he1 <- diag( c(0, 2, 6, 12, 20, 30, 42) * x ^ c(0, 0, 1:5) )
+ }
+ if(i == 2)
+ {
+ he1 <- matrix(0, 7, 7)
+ he1[1, -1] <- sapply(2:7, function(i) prod(x[-c(1, i)]))
+ he1[2, -2] <- sapply(c(1, 3:7), function(i) prod(x[-c(2, i)]))
+ he1[3, -3] <- sapply(c(1:2, 4:7), function(i) prod(x[-c(3, i)]))
+ he1[4, -4] <- sapply(c(1:3, 5:7), function(i) prod(x[-c(4, i)]))
+ he1[5, -5] <- sapply(c(1:4, 6:7), function(i) prod(x[-c(5, i)]))
+ he1[6, -6] <- sapply(c(1:5, 7:7), function(i) prod(x[-c(6, i)]))
+ he1[7, -7] <- sapply(1:6, function(i) prod(x[-c(7, i)]))
+ he2 <- matrix(0, 7, 7)
+ }
+ if(i == 3)
+ {
+ he1 <- diag(rep(2, 7))
+ he2 <- matrix(0, 7, 7)
+ }
+ if(i != 1)
+ return( c(he1[j, k], he2[j, k]) )
+ else
+ return( he1[j, k] )
+ }
>
>
>
>
> dimmu <- 3
>
> #constraint function h(x)
> h <- function(x)
+ {
+ x <- x[1:7]
+ c(prod(x) - 1, sum(x^2) -2, sum(x^3) -3)
+ }
> grh <- function(x, j)
+ {
+ x <- x[1:7]
+ c(prod(x[-j]), 2*x[j], 3*x[j]^2)
+ }
> heh <- function(x, j, k)
+ {
+ x <- x[1:7]
+ c(prod(x[-c(j,k)]), 2*(j==k), 6*x[j]*(j==k))
+ }
>
>
>
> # (3) compute Phi
> #
>
> z <- rexp(sum(dimx) + sum(dimlam) + dimmu)
>
> n <- sum(dimx)
> m <- sum(dimlam)
> x <- z[1:n]
> lam <- z[(n+1):(n+m)]
> mu <- z[-(1:(n+m))]
>
> resphi <- GNE:::funSSRcheck(z, dimx, dimlam, grobj=grfullob, constr=g, grconstr=grfullg, compl=phiFB, joint=h, grjoint=grh, dimmu=dimmu)
>
>
> check <- c(grfullob(x, 1, 1) + lam[1] * grfullg(x, 1, 1) + mu %*% grh(x, 1),
+ grfullob(x, 1, 2) + lam[1] * grfullg(x, 1, 2) + mu %*% grh(x, 2),
+ grfullob(x, 2, 3) + lam[2:3] %*% grfullg(x, 2, 3) + mu %*% grh(x, 3),
+ grfullob(x, 2, 4) + lam[2:3] %*% grfullg(x, 2, 4) + mu %*% grh(x, 4),
+ grfullob(x, 3, 5) + lam[4:5] %*% grfullg(x, 3, 5) + mu %*% grh(x, 5),
+ grfullob(x, 3, 6) + lam[4:5] %*% grfullg(x, 3, 6) + mu %*% grh(x, 6),
+ grfullob(x, 3, 7) + lam[4:5] %*% grfullg(x, 3, 7) + mu %*% grh(x, 7),
+ phiFB(-g(x, 1), lam[1]),
+ phiFB( -g(x, 2)[1], lam[2]),
+ phiFB( -g(x, 2)[2], lam[3]),
+ phiFB( -g(x, 3)[1], lam[4]),
+ phiFB( -g(x, 3)[2], lam[5]),
+ phiFB( -h(x)[1], mu[1]),
+ phiFB( -h(x)[2], mu[2]),
+ phiFB( -h(x)[3], mu[3]))
>
>
> #check
> cat("\n\n________________________________________\n\n")
________________________________________
>
> #part A
> print(cbind(check, res=as.numeric(resphi))[1:n, ])
check res
[1,] 19.622636 19.622636
[2,] 11.416986 11.416986
[3,] 27.584864 27.584864
[4,] -6.921619 -6.921619
[5,] 72.059689 72.059689
[6,] 192.348128 192.348128
[7,] 15.781657 15.781657
> #part B
> print(cbind(check, res=as.numeric(resphi))[(n+1):length(z), ])
check res
[1,] 3131.4321285 3131.4321285
[2,] -1.2080298 -1.2080298
[3,] 21.1333814 21.1333814
[4,] 43.5617521 43.5617521
[5,] 180.8388136 180.8388136
[6,] -0.3205305 -0.3205305
[7,] 37.6548095 37.6548095
[8,] 104.1012595 104.1012595
>
>
> if(sum(abs(check - resphi)) > .Machine$double.eps^(2/3))
+ stop("wrong result")
>
>
>
> z <- rexp(sum(dimx) + dimmu)
> n <- sum(dimx)
> m <- 0
> x <- z[1:n]
> mu <- z[-(1:(n+m))]
>
> resphi <- GNE:::funSSRcheck(z, dimx, grobj=grfullob, compl=phiFB, joint=h, grjoint=grh, dimmu=dimmu)
>
>
> check <- c(grfullob(x, 1, 1) + mu %*% grh(x, 1),
+ grfullob(x, 1, 2) + mu %*% grh(x, 2),
+ grfullob(x, 2, 3) + mu %*% grh(x, 3),
+ grfullob(x, 2, 4) + mu %*% grh(x, 4),
+ grfullob(x, 3, 5) + mu %*% grh(x, 5),
+ grfullob(x, 3, 6) + mu %*% grh(x, 6),
+ grfullob(x, 3, 7) + mu %*% grh(x, 7),
+ phiFB( -h(x)[1], mu[1]),
+ phiFB( -h(x)[2], mu[2]),
+ phiFB( -h(x)[3], mu[3]))
>
>
> #check
> cat("\n\n________________________________________\n\n")
________________________________________
>
> #part A
> print(cbind(check, res=as.numeric(resphi))[1:n, ])
check res
[1,] 2.662304 2.662304
[2,] 90.321922 90.321922
[3,] 24.625583 24.625583
[4,] -222.850188 -222.850188
[5,] 24.279357 24.279357
[6,] 3.481030 3.481030
[7,] 35.344420 35.344420
> #part B
> print(cbind(check, res=as.numeric(resphi))[(n+1):length(z), ])
check res
[1,] -0.8295585 -0.8295585
[2,] 68.6289389 68.6289389
[3,] 334.0304399 334.0304399
>
>
> if(sum(abs(check - resphi)) > .Machine$double.eps^(2/3))
+ stop("wrong result")
>
>
>
>
>
>
>
> # (4) compute Jac Phi
> #
>
> z <- rexp(sum(dimx) + sum(dimlam) + dimmu)
>
> n <- sum(dimx)
> m <- sum(dimlam)
> x <- z[1:n]
> lam <- z[(n+1):(n+m)]
> mu <- z[-(1:(n+m))]
>
>
> resjacphi <- jacSSR(z, dimx, dimlam, heobj=hefullob, constr=g,
+ grconstr=grfullg, heconstr=hefullg, gcompla=GrAphiFB, gcomplb=GrBphiFB,
+ joint=h, grjoint=grh, hejoint=heh, dimmu=dimmu)
Error in jacSSR(z, dimx, dimlam, heobj = hefullob, constr = g, grconstr = grfullg, :
DLL requires the use of native symbols
Execution halted
Running the tests in 'tests/SSR-testarg.R' failed.
Complete output:
> if(!require("GNE"))stop("this test requires package GNE.")
Loading required package: GNE
Loading required package: alabama
Loading required package: numDeriv
Loading required package: nleqslv
Loading required package: BB
Loading required package: SQUAREM
>
>
> try(funSSR("x"))
Error in funSSR("x") : argument "dimx" is missing, with no default
>
> try(funSSR(rep(1, 2) , 1, grobj=function(x) x))
Error in testargfunSSR(z, dimx, dimlam, grobj, arggrobj, constr, argconstr, :
SSR: incompatible dimension for dimlam, dimx, dimmu.
>
> try(funSSR(rep(1, 2), rep(1, 2), grobj=function(x) x))
Error in testargfunSSR(z, dimx, dimlam, grobj, arggrobj, constr, argconstr, :
missing compl argument.
>
> try(funSSR(rep(1, 2), rep(1, 2), grobj=function(x) x, compl=phiFB))
Error in grobj(z, i, j) : unused arguments (i, j)
Error when calling function, below the try output.
[1] "Error in grobj(z, i, j) : unused arguments (i, j)\n"
attr(,"class")
[1] "try-error"
attr(,"condition")
<simpleError in grobj(z, i, j): unused arguments (i, j)>
Arguments are:
[[1]]
[1] 1 1
[[2]]
[1] 1
[[3]]
[1] 1
[[4]]
list()
Error in testfunc(grobjfinal, z, arg = arggrobj, echo = echo, errmess = str) :
the call to grobj(z, 1, 1, arggrobj) does not work. arguments are x .
>
> funSSR(rep(1, 2), rep(1, 2), grobj=function(x, i, j) x, compl=phiFB)
Error in funSSR(rep(1, 2), rep(1, 2), grobj = function(x, i, j) x, compl = phiFB) :
DLL requires the use of native symbols
Execution halted
Running the tests in 'tests/sensi-analysis-riverbasinpollution.R' failed.
Complete output:
> if(!require("GNE"))stop("this test requires package GNE.")
Loading required package: GNE
Loading required package: alabama
Loading required package: numDeriv
Loading required package: nleqslv
Loading required package: BB
Loading required package: SQUAREM
>
> #-------------------------------------------------------------------------------
> # (3) River basin pollution game of Krawczyk and Stanislav Uryasev (2000)
> #-------------------------------------------------------------------------------
>
> myarg0 <- list(
+ C = cbind(c(.1, .12, .15), c(.01, .05, .01)),
+ U = cbind(c(6.5, 5, 5.5), c(4.583, 6.25, 3.75)),
+ K = c(100, 100),
+ E = c(.5, .25, .75),
+ D = c(3, .01)
+ )
>
>
>
> dimx <- c(1, 1, 1)
> #Gr_x_j O_i(x)
> grobj <- function(x, i, j, arg)
+ {
+ dij <- 1*(i == j)
+ res <- -(-arg$D[2] - arg$C[i, 2]*dij) * x[i]
+ res - (arg$D[1] - arg$D[2]*sum(x[1:3]) - arg$C[i, 1] - arg$C[i, 2]*x[i]) * dij
+ }
> #Gr_x_k Gr_x_j O_i(x)
> heobj <- function(x, i, j, k, arg)
+ {
+ dij <- 1*(i == j)
+ dik <- 1*(i == k)
+
+ arg$D[2] * dik + arg$D[2] * dij + 2 * arg$C[i, 2] * dij * dik
+ }
>
> dimlam <- c(2, 2, 2)
> #g_i(x)
> g <- function(x, i, arg)
+ c(sum(arg$U[, 1] * arg$E * x[1:3]) - arg$K[1],
+ sum(arg$U[, 2] * arg$E * x[1:3]) - arg$K[2],
+ -x[1],
+ -x[2],
+ -x[3])
> #Gr_x_j g_i(x)
> grg <- function(x, i, j, arg)
+ c(arg$U[j, 1] * arg$E[j],
+ arg$U[j, 2] * arg$E[j],
+ -1*(i ==j),
+ -1*(i ==j),
+ -1*(i ==j))
> #Gr_x_k Gr_x_j g_i(x)
> heg <- function(x, i, j, k, arg)
+ c(0, 0, 0, 0, 0)
>
> #true value around (21.146, 16.027, 2.724, 0.574, 0.000)
> z0 <- rep(0, sum(dimx)+sum(dimlam))
>
> getNE <- function(x, control=list(maxit=100, trace=0), check=TRUE)
+ {
+ res <- sapply(1:NROW(x), function(i)
+ {
+ myarg <- list(
+ C = cbind(x[i,paste("C",1:3,sep="")], x[i,paste("C",1:3+3,sep="")]),
+ U = cbind(x[i,paste("U",1:3,sep="")], x[i,paste("U",1:3+3,sep="")]),
+ K = x[i,paste("K",1:2,sep="")],
+ E = x[i,paste("E",1:3,sep="")],
+ D = x[i,paste("D",1:2,sep="")]
+ )
+
+ res <- GNE.nseq(z0, dimx, dimlam, grobj=grobj, myarg, heobj=heobj, myarg,
+ constr=g, myarg, grconstr=grg, myarg, heconstr=heg, myarg,
+ compl=phiFB, gcompla=GrAphiFB, gcomplb=GrBphiFB, method="Newton",
+ control=control)
+
+ if(any(res$par[1:3] < 0) && check)
+ return(rep(NA, 3))
+ else
+ return(res$par[1:3])
+ }
+ )
+ }
>
> n <- 10
> Xinputmatrix <- t(replicate(n, unlist(myarg0) * (1 + rnorm(19, 0, .1))))
> X2inputmatrix <- t(replicate(n, unlist(myarg0) * (1 + rnorm(19, 0, .1))))
>
> Youtputs <- t(getNE(Xinputmatrix))
Error in if (any(res$par[1:3] < 0) && check) return(rep(NA, 3)) else return(res$par[1:3]) :
missing value where TRUE/FALSE needed
Calls: t -> getNE -> sapply -> lapply -> FUN
Execution halted
Flavor: r-devel-windows-x86_64
Version: 0.99-4
Check: re-building of vignette outputs
Result: ERROR
Error(s) in re-building vignettes:
--- re-building 'GNE-howto.Rnw' using Sweave
Loading required package: alabama
Loading required package: numDeriv
Loading required package: nleqslv
Loading required package: BB
Loading required package: SQUAREM
Error: processing vignette 'GNE-howto.Rnw' failed with diagnostics:
chunk 6 (label = singjac)
Error in jacSSR(z0, dimx, dimlam, heobj = heobj, myarg, constr = g, grconstr = grg, :
DLL requires the use of native symbols
--- failed re-building 'GNE-howto.Rnw'
SUMMARY: processing the following file failed:
'GNE-howto.Rnw'
Error: Vignette re-building failed.
Execution halted
Flavor: r-devel-windows-x86_64
Version: 0.99-4
Check: tests
Result: ERROR
Running ‘CER-funCER-Rcode-constr.R’ [1s/1s]
Running ‘CER-funCER-Rcode-constrjoint.R’ [1s/1s]
Running ‘CER-funCER-Rcode-joint.R’ [0s/1s]
Running ‘GNEceq-examples.R’ [1s/1s]
Running ‘GNEnseq-examples.R’ [0s/1s]
Running ‘NIR-func-Rcode.R’ [6s/7s]
Running ‘NIRandVIPexample.R’ [1s/2s]
Running ‘SSR-Rcode-funSSRcheck-constrjoint.R’ [1s/1s]
Running ‘SSR-funSSR-Rcode-constr.R’ [1s/1s]
Running ‘SSR-funSSR-funSSRcheck-constr.R’ [1s/1s]
Running ‘SSR-funSSR-funSSRcheck-constrjoint.R’ [1s/1s]
Running ‘SSR-testarg.R’ [0s/0s]
Running ‘complfunc-3Dplot.R’ [1s/1s]
Running ‘complfunc-funcFB.R’ [0s/1s]
Running ‘complfunc-limitgraph.R’ [1s/1s]
Running ‘sensi-analysis-duopoly.R’ [0s/1s]
Running ‘sensi-analysis-genduopoly.R’ [6s/8s]
Running ‘sensi-analysis-riverbasinpollution.R’ [1s/1s]
Running ‘util-testfunc.R’ [0s/1s]
Running the tests in ‘tests/CER-funCER-Rcode-constr.R’ failed.
Complete output:
> if(!require("GNE"))stop("this test requires package GNE.")
Loading required package: GNE
Loading required package: alabama
Loading required package: numDeriv
Loading required package: nleqslv
Loading required package: BB
Loading required package: SQUAREM
>
>
>
> # (1) associated objective functions
> #
>
> dimx <- c(2, 2, 3)
>
> #Gr_x_j O_i(x)
> grfullob <- function(x, i, j)
+ {
+ x <- x[1:7]
+ if(i == 1)
+ {
+ grad <- 3*(x - 1:7)^2
+ }
+ if(i == 2)
+ {
+ grad <- 1:7*(x - 1:7)^(0:6)
+ }
+ if(i == 3)
+ {
+ s <- x[5]^2 + x[6]^2 + x[7]^2 - 5
+ grad <- c(1, 0, 1, 0, 4*x[5]*s, 4*x[6]*s, 4*x[7]*s)
+
+ }
+ grad[j]
+ }
>
>
> #Gr_x_k Gr_x_j O_i(x)
> hefullob <- function(x, i, j, k)
+ {
+ x <- x[1:7]
+ if(i == 1)
+ {
+ he <- diag( 6*(x - 1:7) )
+ }
+ if(i == 2)
+ {
+ he <- diag( c(0, 2, 6, 12, 20, 30, 42)*(x - 1:7)^c(0, 0:5) )
+ }
+ if(i == 3)
+ {
+ s <- x[5]^2 + x[6]^2 + x[7]^2
+
+ he <- rbind(rep(0, 7), rep(0, 7), rep(0, 7), rep(0, 7),
+ c(0, 0, 0, 0, 4*s+8*x[5]^2, 8*x[5]*x[6], 8*x[5]*x[7]),
+ c(0, 0, 0, 0, 8*x[5]*x[6], 4*s+8*x[6]^2, 8*x[6]*x[7]),
+ c(0, 0, 0, 0, 8*x[5]*x[7], 8*x[6]*x[7], 4*s+8*x[7]^2) )
+ }
+ he[j,k]
+ }
>
>
>
> # (2) constraint linked functions
> #
>
> dimlam <- dimw <- c(1, 2, 2)
>
> #constraint function g_i(x)
> g <- function(x, i)
+ {
+ x <- x[1:7]
+ #cat(x[1:5], "|", i, "\n")
+ if(i == 1)
+ res <- sum( x^(1:7) ) -7
+ if(i == 2)
+ res <- c(sum(x) + prod(x) - 14, 20 - sum(x))
+ if(i == 3)
+ res <- c(sum(x^2) + 1, 100 - sum(x))
+ #cat("res", res + par$a, "\n")
+ res
+ }
>
>
> #Gr_x_j g_i(x)
> grfullg <- function(x, i, j)
+ {
+ x <- x[1:7]
+ if(i == 1)
+ {
+ grad <- (1:7) * x ^ (0:6)
+ }
+ if(i == 2)
+ {
+ grad <- 1 + sapply(1:7, function(i) prod(x[-i]))
+ grad <- cbind(grad, -1)
+ }
+ if(i == 3)
+ {
+ grad <- cbind(2*x, -1)
+ }
+
+
+ if(i == 1)
+ res <- grad[j]
+ if(i != 1)
+ res <- grad[j,]
+ as.numeric(res)
+ }
>
>
>
> #Gr_x_k Gr_x_j g_i(x)
> hefullg <- function(x, i, j, k)
+ {
+ x <- x[1:7]
+ if(i == 1)
+ {
+ he1 <- diag( c(0, 2, 6, 12, 20, 30, 42) * x ^ c(0, 0, 1:5) )
+ }
+ if(i == 2)
+ {
+ he1 <- matrix(0, 7, 7)
+ he1[1, -1] <- sapply(2:7, function(i) prod(x[-c(1, i)]))
+ he1[2, -2] <- sapply(c(1, 3:7), function(i) prod(x[-c(2, i)]))
+ he1[3, -3] <- sapply(c(1:2, 4:7), function(i) prod(x[-c(3, i)]))
+ he1[4, -4] <- sapply(c(1:3, 5:7), function(i) prod(x[-c(4, i)]))
+ he1[5, -5] <- sapply(c(1:4, 6:7), function(i) prod(x[-c(5, i)]))
+ he1[6, -6] <- sapply(c(1:5, 7:7), function(i) prod(x[-c(6, i)]))
+ he1[7, -7] <- sapply(1:6, function(i) prod(x[-c(7, i)]))
+
+
+ he2 <- matrix(0, 7, 7)
+
+ }
+ if(i == 3)
+ {
+ he1 <- diag(rep(2, 7))
+ he2 <- matrix(0, 7, 7)
+ }
+ if(i != 1)
+ return( c(he1[j, k], he2[j, k]) )
+ else
+ return( he1[j, k] )
+ }
>
>
>
>
> # (3) compute H
> #
>
> z <- rexp(sum(dimx) + sum(dimlam) + sum(dimw))
>
> n <- sum(dimx)
> m <- sum(dimlam)
> x <- z[1:n]
> lam <- z[(n+1):(n+m)]
> w <- z[(n+m+1):(n+m+m)]
>
> resphi <- funCER(z, dimx, dimlam, grobj=grfullob, constr=g, grconstr=grfullg, echo=TRUE)
[1] 2 2 3
[1] 1 2 2
[1] 17
Error in funSSR(z[1:(n + m + dimmu)], dimx, dimlam, grobj, arggrobj, constr, :
DLL requires the use of native symbols
Calls: funCER -> funSSR
Execution halted
Running the tests in ‘tests/CER-funCER-Rcode-constrjoint.R’ failed.
Complete output:
> if(!require("GNE"))stop("this test requires package GNE.")
Loading required package: GNE
Loading required package: alabama
Loading required package: numDeriv
Loading required package: nleqslv
Loading required package: BB
Loading required package: SQUAREM
>
>
> # (1) associated objective functions
> #
>
> dimx <- c(2, 2, 3)
>
> #Gr_x_j O_i(x)
> grfullob <- function(x, i, j)
+ {
+ x <- x[1:7]
+ if(i == 1)
+ {
+ grad <- 3*(x - 1:7)^2
+ }
+ if(i == 2)
+ {
+ grad <- 1:7*(x - 1:7)^(0:6)
+ }
+ if(i == 3)
+ {
+ s <- x[5]^2 + x[6]^2 + x[7]^2 - 5
+ grad <- c(1, 0, 1, 0, 4*x[5]*s, 4*x[6]*s, 4*x[7]*s)
+
+ }
+ grad[j]
+ }
>
>
> #Gr_x_k Gr_x_j O_i(x)
> hefullob <- function(x, i, j, k)
+ {
+ x <- x[1:7]
+ if(i == 1)
+ {
+ he <- diag( 6*(x - 1:7) )
+ }
+ if(i == 2)
+ {
+ he <- diag( c(0, 2, 6, 12, 20, 30, 42)*(x - 1:7)^c(0, 0:5) )
+ }
+ if(i == 3)
+ {
+ s <- x[5]^2 + x[6]^2 + x[7]^2
+
+ he <- rbind(rep(0, 7), rep(0, 7), rep(0, 7), rep(0, 7),
+ c(0, 0, 0, 0, 4*s+8*x[5]^2, 8*x[5]*x[6], 8*x[5]*x[7]),
+ c(0, 0, 0, 0, 8*x[5]*x[6], 4*s+8*x[6]^2, 8*x[6]*x[7]),
+ c(0, 0, 0, 0, 8*x[5]*x[7], 8*x[6]*x[7], 4*s+8*x[7]^2) )
+ }
+ he[j,k]
+ }
>
>
>
> # (2) constraint linked functions
> #
>
> dimlam <- dimw <- c(1, 2, 2)
>
> #constraint function g_i(x)
> g <- function(x, i)
+ {
+ x <- x[1:7]
+ #cat(x[1:5], "|", i, "\n")
+ if(i == 1)
+ res <- sum( x^(1:7) ) -7
+ if(i == 2)
+ res <- c(sum(x) + prod(x) - 14, 20 - sum(x))
+ if(i == 3)
+ res <- c(sum(x^2) + 1, 100 - sum(x))
+ #cat("res", res + par$a, "\n")
+ res
+ }
>
>
> #Gr_x_j g_i(x)
> grfullg <- function(x, i, j)
+ {
+ x <- x[1:7]
+ if(i == 1)
+ {
+ grad <- (1:7) * x ^ (0:6)
+ }
+ if(i == 2)
+ {
+ grad <- 1 + sapply(1:7, function(i) prod(x[-i]))
+ grad <- cbind(grad, -1)
+ }
+ if(i == 3)
+ {
+ grad <- cbind(2*x, -1)
+ }
+
+
+ if(i == 1)
+ res <- grad[j]
+ if(i != 1)
+ res <- grad[j,]
+ as.numeric(res)
+ }
>
>
>
> #Gr_x_k Gr_x_j g_i(x)
> hefullg <- function(x, i, j, k)
+ {
+ x <- x[1:7]
+ if(i == 1)
+ {
+ he1 <- diag( c(0, 2, 6, 12, 20, 30, 42) * x ^ c(0, 0, 1:5) )
+ }
+ if(i == 2)
+ {
+ he1 <- matrix(0, 7, 7)
+ he1[1, -1] <- sapply(2:7, function(i) prod(x[-c(1, i)]))
+ he1[2, -2] <- sapply(c(1, 3:7), function(i) prod(x[-c(2, i)]))
+ he1[3, -3] <- sapply(c(1:2, 4:7), function(i) prod(x[-c(3, i)]))
+ he1[4, -4] <- sapply(c(1:3, 5:7), function(i) prod(x[-c(4, i)]))
+ he1[5, -5] <- sapply(c(1:4, 6:7), function(i) prod(x[-c(5, i)]))
+ he1[6, -6] <- sapply(c(1:5, 7:7), function(i) prod(x[-c(6, i)]))
+ he1[7, -7] <- sapply(1:6, function(i) prod(x[-c(7, i)]))
+ he2 <- matrix(0, 7, 7)
+ }
+ if(i == 3)
+ {
+ he1 <- diag(rep(2, 7))
+ he2 <- matrix(0, 7, 7)
+ }
+ if(i != 1)
+ return( c(he1[j, k], he2[j, k]) )
+ else
+ return( he1[j, k] )
+ }
>
>
> dimmu <- 3
>
> #constraint function h(x)
> h <- function(x)
+ {
+ x <- x[1:7]
+ c(prod(x) - 1, sum(x^2) -2, sum(x^3) -3)
+ }
> grh <- function(x, j)
+ {
+ x <- x[1:7]
+ c(prod(x[-j]), 2*x[j], 3*x[j]^2)
+ }
> heh <- function(x, j, k)
+ {
+ x <- x[1:7]
+ c(prod(x[-c(j,k)]), 2*(j==k), 6*x[j]*(j==k))
+ }
>
>
>
> # (3) compute H
> #
>
> z <- rexp(sum(dimx) + 2*sum(dimlam) + 2*sum(dimmu))
>
> n <- sum(dimx)
> m <- sum(dimlam)
> x <- z[1:n]
> lam <- z[(n+1):(n+m)]
> mu <- z[(n+m+1):(n+m+dimmu)]
> w <- z[(n+m+dimmu+1):(n+2*m+2*dimmu)]
>
> resphi <- funCER(z, dimx, dimlam, grobj=grfullob, constr=g, grconstr=grfullg, joint=h, grjoint=grh, dimmu=dimmu, echo=TRUE)
[1] 2 2 3
[1] 1 2 2
[1] 23
Error in funSSR(z[1:(n + m + dimmu)], dimx, dimlam, grobj, arggrobj, constr, :
DLL requires the use of native symbols
Calls: funCER -> funSSR
Execution halted
Running the tests in ‘tests/CER-funCER-Rcode-joint.R’ failed.
Complete output:
> if(!require("GNE"))stop("this test requires package GNE.")
Loading required package: GNE
Loading required package: alabama
Loading required package: numDeriv
Loading required package: nleqslv
Loading required package: BB
Loading required package: SQUAREM
>
>
> # (1) associated objective functions
> #
>
> dimx <- c(2, 2, 3)
>
> #Gr_x_j O_i(x)
> grfullob <- function(x, i, j)
+ {
+ x <- x[1:7]
+ if(i == 1)
+ {
+ grad <- 3*(x - 1:7)^2
+ }
+ if(i == 2)
+ {
+ grad <- 1:7*(x - 1:7)^(0:6)
+ }
+ if(i == 3)
+ {
+ s <- x[5]^2 + x[6]^2 + x[7]^2 - 5
+ grad <- c(1, 0, 1, 0, 4*x[5]*s, 4*x[6]*s, 4*x[7]*s)
+
+ }
+ grad[j]
+ }
>
>
> #Gr_x_k Gr_x_j O_i(x)
> hefullob <- function(x, i, j, k)
+ {
+ x <- x[1:7]
+ if(i == 1)
+ {
+ he <- diag( 6*(x - 1:7) )
+ }
+ if(i == 2)
+ {
+ he <- diag( c(0, 2, 6, 12, 20, 30, 42)*(x - 1:7)^c(0, 0:5) )
+ }
+ if(i == 3)
+ {
+ s <- x[5]^2 + x[6]^2 + x[7]^2
+
+ he <- rbind(rep(0, 7), rep(0, 7), rep(0, 7), rep(0, 7),
+ c(0, 0, 0, 0, 4*s+8*x[5]^2, 8*x[5]*x[6], 8*x[5]*x[7]),
+ c(0, 0, 0, 0, 8*x[5]*x[6], 4*s+8*x[6]^2, 8*x[6]*x[7]),
+ c(0, 0, 0, 0, 8*x[5]*x[7], 8*x[6]*x[7], 4*s+8*x[7]^2) )
+ }
+ he[j,k]
+ }
>
>
> dimmu <- 3
>
> #constraint function h(x)
> h <- function(x)
+ {
+ x <- x[1:7]
+ c(prod(x) - 1, sum(x^2) -2, sum(x^3) -3)
+ }
> grh <- function(x, j)
+ {
+ x <- x[1:7]
+ c(prod(x[-j]), 2*x[j], 3*x[j]^2)
+ }
> heh <- function(x, j, k)
+ {
+ x <- x[1:7]
+ c(prod(x[-c(j,k)]), 2*(j==k), 6*x[j]*(j==k))
+ }
>
>
>
> # (3) compute H
> #
>
> z <- rexp(sum(dimx) + 2*sum(dimmu))
>
> n <- sum(dimx)
> m <- 0
> x <- z[1:n]
> lam <- NULL
> mu <- z[(n+m+1):(n+m+dimmu)]
> w <- z[(n+m+dimmu+1):(n+2*m+2*dimmu)]
>
> resphi <- funCER(z, dimx, dimlam, grobj=grfullob, joint=h, grjoint=grh, dimmu=dimmu, echo=TRUE)
[1] 2 2 3
[1] 0 0 0
[1] 13
Error in funSSR(z[1:(n + m + dimmu)], dimx, dimlam, grobj, arggrobj, constr, :
DLL requires the use of native symbols
Calls: funCER -> funSSR
Execution halted
Running the tests in ‘tests/GNEnseq-examples.R’ failed.
Complete output:
> if(!require("GNE"))stop("this test requires package GNE.")
Loading required package: GNE
Loading required package: alabama
Loading required package: numDeriv
Loading required package: nleqslv
Loading required package: BB
Loading required package: SQUAREM
>
> itermax <- 10
>
> #-------------------------------------------------------------------------------
> # (1) Example 5 of von Facchinei et al. (2007)
> #-------------------------------------------------------------------------------
>
> dimx <- c(1, 1)
> #Gr_x_j O_i(x)
> grobj <- function(x, i, j)
+ {
+ if(i == 1)
+ res <- c(2*(x[1]-1), 0)
+ if(i == 2)
+ res <- c(0, 2*(x[2]-1/2))
+ res[j]
+ }
> #Gr_x_k Gr_x_j O_i(x)
> heobj <- function(x, i, j, k)
+ 2 * (i == j && j == k)
>
> dimlam <- c(1, 1)
> #constraint function g_i(x)
> g <- function(x, i)
+ sum(x[1:2]) - 1
> #Gr_x_j g_i(x)
> grg <- function(x, i, j)
+ 1
> #Gr_x_k Gr_x_j g_i(x)
> heg <- function(x, i, j, k)
+ 0
>
>
>
> #true value is (3/4, 1/4, 1/2, 1/2)
>
> z0 <- rep(0, sum(dimx)+sum(dimlam))
>
> funSSR(z0, dimx, dimlam, grobj=grobj, constr=g, grconstr=grg, compl=phiFB, echo=FALSE)
Error in funSSR(z0, dimx, dimlam, grobj = grobj, constr = g, grconstr = grg, :
DLL requires the use of native symbols
Execution halted
Running the tests in ‘tests/SSR-Rcode-funSSRcheck-constrjoint.R’ failed.
Complete output:
> if(!require("GNE"))stop("this test requires package GNE.")
Loading required package: GNE
Loading required package: alabama
Loading required package: numDeriv
Loading required package: nleqslv
Loading required package: BB
Loading required package: SQUAREM
>
>
> # (1) associated objective functions
> #
>
> dimx <- c(2, 2, 3)
>
> #Gr_x_j O_i(x)
> grfullob <- function(x, i, j)
+ {
+ x <- x[1:7]
+ if(i == 1)
+ {
+ grad <- 3*(x - 1:7)^2
+ }
+ if(i == 2)
+ {
+ grad <- 1:7*(x - 1:7)^(0:6)
+ }
+ if(i == 3)
+ {
+ s <- x[5]^2 + x[6]^2 + x[7]^2 - 5
+ grad <- c(1, 0, 1, 0, 4*x[5]*s, 4*x[6]*s, 4*x[7]*s)
+
+ }
+ grad[j]
+ }
>
>
> #Gr_x_k Gr_x_j O_i(x)
> hefullob <- function(x, i, j, k)
+ {
+ x <- x[1:7]
+ if(i == 1)
+ {
+ he <- diag( 6*(x - 1:7) )
+ }
+ if(i == 2)
+ {
+ he <- diag( c(0, 2, 6, 12, 20, 30, 42)*(x - 1:7)^c(0, 0:5) )
+ }
+ if(i == 3)
+ {
+ s <- x[5]^2 + x[6]^2 + x[7]^2
+
+ he <- rbind(rep(0, 7), rep(0, 7), rep(0, 7), rep(0, 7),
+ c(0, 0, 0, 0, 4*s+8*x[5]^2, 8*x[5]*x[6], 8*x[5]*x[7]),
+ c(0, 0, 0, 0, 8*x[5]*x[6], 4*s+8*x[6]^2, 8*x[6]*x[7]),
+ c(0, 0, 0, 0, 8*x[5]*x[7], 8*x[6]*x[7], 4*s+8*x[7]^2) )
+ }
+ he[j,k]
+ }
>
>
>
> # (2) constraint linked functions
> #
>
> dimlam <- c(1, 2, 2)
>
> #constraint function g_i(x)
> g <- function(x, i)
+ {
+ x <- x[1:7]
+ #cat(x[1:5], "|", i, "\n")
+ if(i == 1)
+ res <- sum( x^(1:7) ) -7
+ if(i == 2)
+ res <- c(sum(x) + prod(x) - 14, 20 - sum(x))
+ if(i == 3)
+ res <- c(sum(x^2) + 1, 100 - sum(x))
+ #cat("res", res + par$a, "\n")
+ res
+ }
>
>
> #Gr_x_j g_i(x)
> grfullg <- function(x, i, j)
+ {
+ x <- x[1:7]
+ if(i == 1)
+ {
+ grad <- (1:7) * x ^ (0:6)
+ }
+ if(i == 2)
+ {
+ grad <- 1 + sapply(1:7, function(i) prod(x[-i]))
+ grad <- cbind(grad, -1)
+ }
+ if(i == 3)
+ {
+ grad <- cbind(2*x, -1)
+ }
+ if(i == 1) res <- grad[j]
+ if(i != 1) res <- grad[j,]
+ as.numeric(res)
+ }
>
>
>
> #Gr_x_k Gr_x_j g_i(x)
> hefullg <- function(x, i, j, k)
+ {
+ x <- x[1:7]
+ if(i == 1)
+ {
+ he1 <- diag( c(0, 2, 6, 12, 20, 30, 42) * x ^ c(0, 0, 1:5) )
+ }
+ if(i == 2)
+ {
+ he1 <- matrix(0, 7, 7)
+ he1[1, -1] <- sapply(2:7, function(i) prod(x[-c(1, i)]))
+ he1[2, -2] <- sapply(c(1, 3:7), function(i) prod(x[-c(2, i)]))
+ he1[3, -3] <- sapply(c(1:2, 4:7), function(i) prod(x[-c(3, i)]))
+ he1[4, -4] <- sapply(c(1:3, 5:7), function(i) prod(x[-c(4, i)]))
+ he1[5, -5] <- sapply(c(1:4, 6:7), function(i) prod(x[-c(5, i)]))
+ he1[6, -6] <- sapply(c(1:5, 7:7), function(i) prod(x[-c(6, i)]))
+ he1[7, -7] <- sapply(1:6, function(i) prod(x[-c(7, i)]))
+ he2 <- matrix(0, 7, 7)
+ }
+ if(i == 3)
+ {
+ he1 <- diag(rep(2, 7))
+ he2 <- matrix(0, 7, 7)
+ }
+ if(i != 1)
+ return( c(he1[j, k], he2[j, k]) )
+ else
+ return( he1[j, k] )
+ }
>
>
>
>
> dimmu <- 3
>
> #constraint function h(x)
> h <- function(x)
+ {
+ x <- x[1:7]
+ c(prod(x) - 1, sum(x^2) -2, sum(x^3) -3)
+ }
> grh <- function(x, j)
+ {
+ x <- x[1:7]
+ c(prod(x[-j]), 2*x[j], 3*x[j]^2)
+ }
> heh <- function(x, j, k)
+ {
+ x <- x[1:7]
+ c(prod(x[-c(j,k)]), 2*(j==k), 6*x[j]*(j==k))
+ }
>
>
>
> # (3) compute Phi
> #
>
> z <- rexp(sum(dimx) + sum(dimlam) + dimmu)
>
> n <- sum(dimx)
> m <- sum(dimlam)
> x <- z[1:n]
> lam <- z[(n+1):(n+m)]
> mu <- z[-(1:(n+m))]
>
> g(z, 1)
[1] 395.5627
> g(z, 2)
[1] -6.251103 12.375583
> g(z, 3)
[1] 14.73507 92.37558
>
> resphi <- funSSR(z, dimx, dimlam, grobj=grfullob, constr=g, grconstr=grfullg, compl=phiFB, joint=h, grjoint=grh, dimmu=dimmu)
Error in funSSR(z, dimx, dimlam, grobj = grfullob, constr = g, grconstr = grfullg, :
DLL requires the use of native symbols
Execution halted
Running the tests in ‘tests/SSR-funSSR-Rcode-constr.R’ failed.
Complete output:
> if(!require("GNE"))stop("this test requires package GNE.")
Loading required package: GNE
Loading required package: alabama
Loading required package: numDeriv
Loading required package: nleqslv
Loading required package: BB
Loading required package: SQUAREM
>
>
> # (1) associated objective functions
> #
>
> dimx <- c(2, 2, 3)
>
> #Gr_x_j O_i(x)
> grfullob <- function(x, i, j)
+ {
+ x <- x[1:7]
+ if(i == 1)
+ {
+ grad <- 3*(x - 1:7)^2
+ }
+ if(i == 2)
+ {
+ grad <- 1:7*(x - 1:7)^(0:6)
+ }
+ if(i == 3)
+ {
+ s <- x[5]^2 + x[6]^2 + x[7]^2 - 5
+ grad <- c(1, 0, 1, 0, 4*x[5]*s, 4*x[6]*s, 4*x[7]*s)
+
+ }
+ grad[j]
+ }
>
>
> #Gr_x_k Gr_x_j O_i(x)
> hefullob <- function(x, i, j, k)
+ {
+ x <- x[1:7]
+ if(i == 1)
+ {
+ he <- diag( 6*(x - 1:7) )
+ }
+ if(i == 2)
+ {
+ he <- diag( c(0, 2, 6, 12, 20, 30, 42)*(x - 1:7)^c(0, 0:5) )
+ }
+ if(i == 3)
+ {
+ s <- x[5]^2 + x[6]^2 + x[7]^2
+
+ he <- rbind(rep(0, 7), rep(0, 7), rep(0, 7), rep(0, 7),
+ c(0, 0, 0, 0, 4*s+8*x[5]^2, 8*x[5]*x[6], 8*x[5]*x[7]),
+ c(0, 0, 0, 0, 8*x[5]*x[6], 4*s+8*x[6]^2, 8*x[6]*x[7]),
+ c(0, 0, 0, 0, 8*x[5]*x[7], 8*x[6]*x[7], 4*s+8*x[7]^2) )
+ }
+ he[j,k]
+ }
>
>
>
> # (2) constraint linked functions
> #
>
> dimlam <- c(1, 2, 2)
>
> #constraint function g_i(x)
> g <- function(x, i)
+ {
+ x <- x[1:7]
+ #cat(x[1:5], "|", i, "\n")
+ if(i == 1)
+ res <- sum( x^(1:7) ) -7
+ if(i == 2)
+ res <- c(sum(x) + prod(x) - 14, 20 - sum(x))
+ if(i == 3)
+ res <- c(sum(x^2) + 1, 100 - sum(x))
+ #cat("res", res + par$a, "\n")
+ res
+ }
>
>
> #Gr_x_j g_i(x)
> grfullg <- function(x, i, j)
+ {
+ x <- x[1:7]
+ if(i == 1)
+ {
+ grad <- (1:7) * x ^ (0:6)
+ }
+ if(i == 2)
+ {
+ grad <- 1 + sapply(1:7, function(i) prod(x[-i]))
+ grad <- cbind(grad, -1)
+ }
+ if(i == 3)
+ {
+ grad <- cbind(2*x, -1)
+ }
+
+
+ if(i == 1)
+ res <- grad[j]
+ if(i != 1)
+ res <- grad[j,]
+ as.numeric(res)
+ }
>
>
>
> #Gr_x_k Gr_x_j g_i(x)
> hefullg <- function(x, i, j, k)
+ {
+ x <- x[1:7]
+ if(i == 1)
+ {
+ he1 <- diag( c(0, 2, 6, 12, 20, 30, 42) * x ^ c(0, 0, 1:5) )
+ }
+ if(i == 2)
+ {
+ he1 <- matrix(0, 7, 7)
+ he1[1, -1] <- sapply(2:7, function(i) prod(x[-c(1, i)]))
+ he1[2, -2] <- sapply(c(1, 3:7), function(i) prod(x[-c(2, i)]))
+ he1[3, -3] <- sapply(c(1:2, 4:7), function(i) prod(x[-c(3, i)]))
+ he1[4, -4] <- sapply(c(1:3, 5:7), function(i) prod(x[-c(4, i)]))
+ he1[5, -5] <- sapply(c(1:4, 6:7), function(i) prod(x[-c(5, i)]))
+ he1[6, -6] <- sapply(c(1:5, 7:7), function(i) prod(x[-c(6, i)]))
+ he1[7, -7] <- sapply(1:6, function(i) prod(x[-c(7, i)]))
+
+
+ he2 <- matrix(0, 7, 7)
+
+ }
+ if(i == 3)
+ {
+ he1 <- diag(rep(2, 7))
+ he2 <- matrix(0, 7, 7)
+ }
+ if(i != 1)
+ return( c(he1[j, k], he2[j, k]) )
+ else
+ return( he1[j, k] )
+ }
>
>
>
>
> # (3) compute Phi
> #
>
> z <- rexp(sum(dimx) + sum(dimlam))
>
> n <- sum(dimx)
> m <- sum(dimlam)
> x <- z[1:n]
> lam <- z[(n+1):(n+m)]
>
> resphi <- funSSR(z, dimx, dimlam, grobj=grfullob, constr=g, grconstr=grfullg, compl=phiFB)
Error in funSSR(z, dimx, dimlam, grobj = grfullob, constr = g, grconstr = grfullg, :
DLL requires the use of native symbols
Execution halted
Running the tests in ‘tests/SSR-funSSR-funSSRcheck-constr.R’ failed.
Complete output:
> if(!require("GNE"))stop("this test requires package GNE.")
Loading required package: GNE
Loading required package: alabama
Loading required package: numDeriv
Loading required package: nleqslv
Loading required package: BB
Loading required package: SQUAREM
>
>
> # (1) associated objective functions
> #
>
> dimx <- c(2, 2, 3)
>
> #Gr_x_j O_i(x)
> grfullob <- function(x, i, j)
+ {
+ x <- x[1:7]
+ if(i == 1)
+ {
+ grad <- 3*(x - 1:7)^2
+ }
+ if(i == 2)
+ {
+ grad <- 1:7*(x - 1:7)^(0:6)
+ }
+ if(i == 3)
+ {
+ s <- x[5]^2 + x[6]^2 + x[7]^2 - 5
+ grad <- c(1, 0, 1, 0, 4*x[5]*s, 4*x[6]*s, 4*x[7]*s)
+
+ }
+ grad[j]
+ }
>
>
> #Gr_x_k Gr_x_j O_i(x)
> hefullob <- function(x, i, j, k)
+ {
+ x <- x[1:7]
+ if(i == 1)
+ {
+ he <- diag( 6*(x - 1:7) )
+ }
+ if(i == 2)
+ {
+ he <- diag( c(0, 2, 6, 12, 20, 30, 42)*(x - 1:7)^c(0, 0:5) )
+ }
+ if(i == 3)
+ {
+ s <- x[5]^2 + x[6]^2 + x[7]^2
+
+ he <- rbind(rep(0, 7), rep(0, 7), rep(0, 7), rep(0, 7),
+ c(0, 0, 0, 0, 4*s+8*x[5]^2, 8*x[5]*x[6], 8*x[5]*x[7]),
+ c(0, 0, 0, 0, 8*x[5]*x[6], 4*s+8*x[6]^2, 8*x[6]*x[7]),
+ c(0, 0, 0, 0, 8*x[5]*x[7], 8*x[6]*x[7], 4*s+8*x[7]^2) )
+ }
+ he[j,k]
+ }
>
>
>
> # (2) constraint linked functions
> #
>
> dimlam <- c(1, 2, 2)
>
> #constraint function g_i(x)
> g <- function(x, i)
+ {
+ x <- x[1:7]
+ #cat(x[1:5], "|", i, "\n")
+ if(i == 1)
+ res <- sum( x^(1:7) ) -7
+ if(i == 2)
+ res <- c(sum(x) + prod(x) - 14, 20 - sum(x))
+ if(i == 3)
+ res <- c(sum(x^2) + 1, 100 - sum(x))
+ #cat("res", res + par$a, "\n")
+ res
+ }
>
>
> #Gr_x_j g_i(x)
> grfullg <- function(x, i, j)
+ {
+ x <- x[1:7]
+ if(i == 1)
+ {
+ grad <- (1:7) * x ^ (0:6)
+ }
+ if(i == 2)
+ {
+ grad <- 1 + sapply(1:7, function(i) prod(x[-i]))
+ grad <- cbind(grad, -1)
+ }
+ if(i == 3)
+ {
+ grad <- cbind(2*x, -1)
+ }
+
+
+ if(i == 1)
+ res <- grad[j]
+ if(i != 1)
+ res <- grad[j,]
+ as.numeric(res)
+ }
>
>
>
> #Gr_x_k Gr_x_j g_i(x)
> hefullg <- function(x, i, j, k)
+ {
+ x <- x[1:7]
+ if(i == 1)
+ {
+ he1 <- diag( c(0, 2, 6, 12, 20, 30, 42) * x ^ c(0, 0, 1:5) )
+ }
+ if(i == 2)
+ {
+ he1 <- matrix(0, 7, 7)
+ he1[1, -1] <- sapply(2:7, function(i) prod(x[-c(1, i)]))
+ he1[2, -2] <- sapply(c(1, 3:7), function(i) prod(x[-c(2, i)]))
+ he1[3, -3] <- sapply(c(1:2, 4:7), function(i) prod(x[-c(3, i)]))
+ he1[4, -4] <- sapply(c(1:3, 5:7), function(i) prod(x[-c(4, i)]))
+ he1[5, -5] <- sapply(c(1:4, 6:7), function(i) prod(x[-c(5, i)]))
+ he1[6, -6] <- sapply(c(1:5, 7:7), function(i) prod(x[-c(6, i)]))
+ he1[7, -7] <- sapply(1:6, function(i) prod(x[-c(7, i)]))
+
+
+ he2 <- matrix(0, 7, 7)
+
+ }
+ if(i == 3)
+ {
+ he1 <- diag(rep(2, 7))
+ he2 <- matrix(0, 7, 7)
+ }
+ if(i != 1)
+ return( c(he1[j, k], he2[j, k]) )
+ else
+ return( he1[j, k] )
+ }
>
>
>
>
> # (3) compute Phi
> #
>
> z <- rexp(sum(dimx) + sum(dimlam))
>
> n <- sum(dimx)
> m <- sum(dimlam)
> x <- z[1:n]
> lam <- z[(n+1):(n+m)]
>
> resphi <- funSSR(z, dimx, dimlam, grobj=grfullob, constr=g, grconstr=grfullg, compl=phiFB)
Error in funSSR(z, dimx, dimlam, grobj = grfullob, constr = g, grconstr = grfullg, :
DLL requires the use of native symbols
Execution halted
Running the tests in ‘tests/SSR-funSSR-funSSRcheck-constrjoint.R’ failed.
Complete output:
> if(!require("GNE"))stop("this test requires package GNE.")
Loading required package: GNE
Loading required package: alabama
Loading required package: numDeriv
Loading required package: nleqslv
Loading required package: BB
Loading required package: SQUAREM
>
>
> # (1) associated objective functions
> #
>
> dimx <- c(2, 2, 3)
>
> #Gr_x_j O_i(x)
> grfullob <- function(x, i, j)
+ {
+ x <- x[1:7]
+ if(i == 1)
+ {
+ grad <- 3*(x - 1:7)^2
+ }
+ if(i == 2)
+ {
+ grad <- 1:7*(x - 1:7)^(0:6)
+ }
+ if(i == 3)
+ {
+ s <- x[5]^2 + x[6]^2 + x[7]^2 - 5
+ grad <- c(1, 0, 1, 0, 4*x[5]*s, 4*x[6]*s, 4*x[7]*s)
+
+ }
+ grad[j]
+ }
>
>
> #Gr_x_k Gr_x_j O_i(x)
> hefullob <- function(x, i, j, k)
+ {
+ x <- x[1:7]
+ if(i == 1)
+ {
+ he <- diag( 6*(x - 1:7) )
+ }
+ if(i == 2)
+ {
+ he <- diag( c(0, 2, 6, 12, 20, 30, 42)*(x - 1:7)^c(0, 0:5) )
+ }
+ if(i == 3)
+ {
+ s <- x[5]^2 + x[6]^2 + x[7]^2
+
+ he <- rbind(rep(0, 7), rep(0, 7), rep(0, 7), rep(0, 7),
+ c(0, 0, 0, 0, 4*s+8*x[5]^2, 8*x[5]*x[6], 8*x[5]*x[7]),
+ c(0, 0, 0, 0, 8*x[5]*x[6], 4*s+8*x[6]^2, 8*x[6]*x[7]),
+ c(0, 0, 0, 0, 8*x[5]*x[7], 8*x[6]*x[7], 4*s+8*x[7]^2) )
+ }
+ he[j,k]
+ }
>
>
>
> # (2) constraint linked functions
> #
>
> dimlam <- c(1, 2, 2)
>
> #constraint function g_i(x)
> g <- function(x, i)
+ {
+ x <- x[1:7]
+ #cat(x[1:5], "|", i, "\n")
+ if(i == 1)
+ res <- sum( x^(1:7) ) -7
+ if(i == 2)
+ res <- c(sum(x) + prod(x) - 14, 20 - sum(x))
+ if(i == 3)
+ res <- c(sum(x^2) + 1, 100 - sum(x))
+ #cat("res", res + par$a, "\n")
+ res
+ }
>
>
> #Gr_x_j g_i(x)
> grfullg <- function(x, i, j)
+ {
+ x <- x[1:7]
+ if(i == 1)
+ {
+ grad <- (1:7) * x ^ (0:6)
+ }
+ if(i == 2)
+ {
+ grad <- 1 + sapply(1:7, function(i) prod(x[-i]))
+ grad <- cbind(grad, -1)
+ }
+ if(i == 3)
+ {
+ grad <- cbind(2*x, -1)
+ }
+ if(i == 1) res <- grad[j]
+ if(i != 1) res <- grad[j,]
+ as.numeric(res)
+ }
>
>
>
> #Gr_x_k Gr_x_j g_i(x)
> hefullg <- function(x, i, j, k)
+ {
+ x <- x[1:7]
+ if(i == 1)
+ {
+ he1 <- diag( c(0, 2, 6, 12, 20, 30, 42) * x ^ c(0, 0, 1:5) )
+ }
+ if(i == 2)
+ {
+ he1 <- matrix(0, 7, 7)
+ he1[1, -1] <- sapply(2:7, function(i) prod(x[-c(1, i)]))
+ he1[2, -2] <- sapply(c(1, 3:7), function(i) prod(x[-c(2, i)]))
+ he1[3, -3] <- sapply(c(1:2, 4:7), function(i) prod(x[-c(3, i)]))
+ he1[4, -4] <- sapply(c(1:3, 5:7), function(i) prod(x[-c(4, i)]))
+ he1[5, -5] <- sapply(c(1:4, 6:7), function(i) prod(x[-c(5, i)]))
+ he1[6, -6] <- sapply(c(1:5, 7:7), function(i) prod(x[-c(6, i)]))
+ he1[7, -7] <- sapply(1:6, function(i) prod(x[-c(7, i)]))
+ he2 <- matrix(0, 7, 7)
+ }
+ if(i == 3)
+ {
+ he1 <- diag(rep(2, 7))
+ he2 <- matrix(0, 7, 7)
+ }
+ if(i != 1)
+ return( c(he1[j, k], he2[j, k]) )
+ else
+ return( he1[j, k] )
+ }
>
>
>
>
> dimmu <- 3
>
> #constraint function h(x)
> h <- function(x)
+ {
+ x <- x[1:7]
+ c(prod(x) - 1, sum(x^2) -2, sum(x^3) -3)
+ }
> grh <- function(x, j)
+ {
+ x <- x[1:7]
+ c(prod(x[-j]), 2*x[j], 3*x[j]^2)
+ }
> heh <- function(x, j, k)
+ {
+ x <- x[1:7]
+ c(prod(x[-c(j,k)]), 2*(j==k), 6*x[j]*(j==k))
+ }
>
>
>
> # (3) compute Phi
> #
>
> z <- rexp(sum(dimx) + sum(dimlam) + dimmu)
>
> n <- sum(dimx)
> m <- sum(dimlam)
> x <- z[1:n]
> lam <- z[(n+1):(n+m)]
> mu <- z[-(1:(n+m))]
>
> resphi <- GNE:::funSSRcheck(z, dimx, dimlam, grobj=grfullob, constr=g, grconstr=grfullg, compl=phiFB, joint=h, grjoint=grh, dimmu=dimmu)
>
>
> check <- c(grfullob(x, 1, 1) + lam[1] * grfullg(x, 1, 1) + mu %*% grh(x, 1),
+ grfullob(x, 1, 2) + lam[1] * grfullg(x, 1, 2) + mu %*% grh(x, 2),
+ grfullob(x, 2, 3) + lam[2:3] %*% grfullg(x, 2, 3) + mu %*% grh(x, 3),
+ grfullob(x, 2, 4) + lam[2:3] %*% grfullg(x, 2, 4) + mu %*% grh(x, 4),
+ grfullob(x, 3, 5) + lam[4:5] %*% grfullg(x, 3, 5) + mu %*% grh(x, 5),
+ grfullob(x, 3, 6) + lam[4:5] %*% grfullg(x, 3, 6) + mu %*% grh(x, 6),
+ grfullob(x, 3, 7) + lam[4:5] %*% grfullg(x, 3, 7) + mu %*% grh(x, 7),
+ phiFB(-g(x, 1), lam[1]),
+ phiFB( -g(x, 2)[1], lam[2]),
+ phiFB( -g(x, 2)[2], lam[3]),
+ phiFB( -g(x, 3)[1], lam[4]),
+ phiFB( -g(x, 3)[2], lam[5]),
+ phiFB( -h(x)[1], mu[1]),
+ phiFB( -h(x)[2], mu[2]),
+ phiFB( -h(x)[3], mu[3]))
>
>
> #check
> cat("\n\n________________________________________\n\n")
________________________________________
>
> #part A
> print(cbind(check, res=as.numeric(resphi))[1:n, ])
check res
[1,] 1.015003 1.015003
[2,] 3.580902 3.580902
[3,] 26.265700 26.265700
[4,] -189.879903 -189.879903
[5,] -2.642749 -2.642749
[6,] -2.580795 -2.580795
[7,] -8.912703 -8.912703
> #part B
> print(cbind(check, res=as.numeric(resphi))[(n+1):length(z), ])
check res
[1,] -0.31882400 -0.31882400
[2,] -1.03526649 -1.03526649
[3,] 33.13601264 33.13601264
[4,] 6.46459542 6.46459542
[5,] 192.69313602 192.69313602
[6,] -0.64771072 -0.64771072
[7,] 1.25516769 1.25516769
[8,] -0.05440948 -0.05440948
>
>
> if(sum(abs(check - resphi)) > .Machine$double.eps^(2/3))
+ stop("wrong result")
>
>
>
> z <- rexp(sum(dimx) + dimmu)
> n <- sum(dimx)
> m <- 0
> x <- z[1:n]
> mu <- z[-(1:(n+m))]
>
> resphi <- GNE:::funSSRcheck(z, dimx, grobj=grfullob, compl=phiFB, joint=h, grjoint=grh, dimmu=dimmu)
>
>
> check <- c(grfullob(x, 1, 1) + mu %*% grh(x, 1),
+ grfullob(x, 1, 2) + mu %*% grh(x, 2),
+ grfullob(x, 2, 3) + mu %*% grh(x, 3),
+ grfullob(x, 2, 4) + mu %*% grh(x, 4),
+ grfullob(x, 3, 5) + mu %*% grh(x, 5),
+ grfullob(x, 3, 6) + mu %*% grh(x, 6),
+ grfullob(x, 3, 7) + mu %*% grh(x, 7),
+ phiFB( -h(x)[1], mu[1]),
+ phiFB( -h(x)[2], mu[2]),
+ phiFB( -h(x)[3], mu[3]))
>
>
> #check
> cat("\n\n________________________________________\n\n")
________________________________________
>
> #part A
> print(cbind(check, res=as.numeric(resphi))[1:n, ])
check res
[1,] 28.3910270 28.3910270
[2,] 8.2127921 8.2127921
[3,] 23.4009590 23.4009590
[4,] -238.5655176 -238.5655176
[5,] -0.6296123 -0.6296123
[6,] -1.8145695 -1.8145695
[7,] -1.4504121 -1.4504121
> #part B
> print(cbind(check, res=as.numeric(resphi))[(n+1):length(z), ])
check res
[1,] -0.5610685 -0.5610685
[2,] 14.3411011 14.3411011
[3,] 31.3599631 31.3599631
>
>
> if(sum(abs(check - resphi)) > .Machine$double.eps^(2/3))
+ stop("wrong result")
>
>
>
>
>
>
>
> # (4) compute Jac Phi
> #
>
> z <- rexp(sum(dimx) + sum(dimlam) + dimmu)
>
> n <- sum(dimx)
> m <- sum(dimlam)
> x <- z[1:n]
> lam <- z[(n+1):(n+m)]
> mu <- z[-(1:(n+m))]
>
>
> resjacphi <- jacSSR(z, dimx, dimlam, heobj=hefullob, constr=g,
+ grconstr=grfullg, heconstr=hefullg, gcompla=GrAphiFB, gcomplb=GrBphiFB,
+ joint=h, grjoint=grh, hejoint=heh, dimmu=dimmu)
Error in jacSSR(z, dimx, dimlam, heobj = hefullob, constr = g, grconstr = grfullg, :
DLL requires the use of native symbols
Execution halted
Running the tests in ‘tests/SSR-testarg.R’ failed.
Complete output:
> if(!require("GNE"))stop("this test requires package GNE.")
Loading required package: GNE
Loading required package: alabama
Loading required package: numDeriv
Loading required package: nleqslv
Loading required package: BB
Loading required package: SQUAREM
>
>
> try(funSSR("x"))
Error in funSSR("x") : argument "dimx" is missing, with no default
>
> try(funSSR(rep(1, 2) , 1, grobj=function(x) x))
Error in testargfunSSR(z, dimx, dimlam, grobj, arggrobj, constr, argconstr, :
SSR: incompatible dimension for dimlam, dimx, dimmu.
>
> try(funSSR(rep(1, 2), rep(1, 2), grobj=function(x) x))
Error in testargfunSSR(z, dimx, dimlam, grobj, arggrobj, constr, argconstr, :
missing compl argument.
>
> try(funSSR(rep(1, 2), rep(1, 2), grobj=function(x) x, compl=phiFB))
Error in grobj(z, i, j) : unused arguments (i, j)
Error when calling function, below the try output.
[1] "Error in grobj(z, i, j) : unused arguments (i, j)\n"
attr(,"class")
[1] "try-error"
attr(,"condition")
<simpleError in grobj(z, i, j): unused arguments (i, j)>
Arguments are:
[[1]]
[1] 1 1
[[2]]
[1] 1
[[3]]
[1] 1
[[4]]
list()
Error in testfunc(grobjfinal, z, arg = arggrobj, echo = echo, errmess = str) :
the call to grobj(z, 1, 1, arggrobj) does not work. arguments are x .
>
> funSSR(rep(1, 2), rep(1, 2), grobj=function(x, i, j) x, compl=phiFB)
Error in funSSR(rep(1, 2), rep(1, 2), grobj = function(x, i, j) x, compl = phiFB) :
DLL requires the use of native symbols
Execution halted
Running the tests in ‘tests/sensi-analysis-riverbasinpollution.R’ failed.
Complete output:
> if(!require("GNE"))stop("this test requires package GNE.")
Loading required package: GNE
Loading required package: alabama
Loading required package: numDeriv
Loading required package: nleqslv
Loading required package: BB
Loading required package: SQUAREM
>
> #-------------------------------------------------------------------------------
> # (3) River basin pollution game of Krawczyk and Stanislav Uryasev (2000)
> #-------------------------------------------------------------------------------
>
> myarg0 <- list(
+ C = cbind(c(.1, .12, .15), c(.01, .05, .01)),
+ U = cbind(c(6.5, 5, 5.5), c(4.583, 6.25, 3.75)),
+ K = c(100, 100),
+ E = c(.5, .25, .75),
+ D = c(3, .01)
+ )
>
>
>
> dimx <- c(1, 1, 1)
> #Gr_x_j O_i(x)
> grobj <- function(x, i, j, arg)
+ {
+ dij <- 1*(i == j)
+ res <- -(-arg$D[2] - arg$C[i, 2]*dij) * x[i]
+ res - (arg$D[1] - arg$D[2]*sum(x[1:3]) - arg$C[i, 1] - arg$C[i, 2]*x[i]) * dij
+ }
> #Gr_x_k Gr_x_j O_i(x)
> heobj <- function(x, i, j, k, arg)
+ {
+ dij <- 1*(i == j)
+ dik <- 1*(i == k)
+
+ arg$D[2] * dik + arg$D[2] * dij + 2 * arg$C[i, 2] * dij * dik
+ }
>
> dimlam <- c(2, 2, 2)
> #g_i(x)
> g <- function(x, i, arg)
+ c(sum(arg$U[, 1] * arg$E * x[1:3]) - arg$K[1],
+ sum(arg$U[, 2] * arg$E * x[1:3]) - arg$K[2],
+ -x[1],
+ -x[2],
+ -x[3])
> #Gr_x_j g_i(x)
> grg <- function(x, i, j, arg)
+ c(arg$U[j, 1] * arg$E[j],
+ arg$U[j, 2] * arg$E[j],
+ -1*(i ==j),
+ -1*(i ==j),
+ -1*(i ==j))
> #Gr_x_k Gr_x_j g_i(x)
> heg <- function(x, i, j, k, arg)
+ c(0, 0, 0, 0, 0)
>
> #true value around (21.146, 16.027, 2.724, 0.574, 0.000)
> z0 <- rep(0, sum(dimx)+sum(dimlam))
>
> getNE <- function(x, control=list(maxit=100, trace=0), check=TRUE)
+ {
+ res <- sapply(1:NROW(x), function(i)
+ {
+ myarg <- list(
+ C = cbind(x[i,paste("C",1:3,sep="")], x[i,paste("C",1:3+3,sep="")]),
+ U = cbind(x[i,paste("U",1:3,sep="")], x[i,paste("U",1:3+3,sep="")]),
+ K = x[i,paste("K",1:2,sep="")],
+ E = x[i,paste("E",1:3,sep="")],
+ D = x[i,paste("D",1:2,sep="")]
+ )
+
+ res <- GNE.nseq(z0, dimx, dimlam, grobj=grobj, myarg, heobj=heobj, myarg,
+ constr=g, myarg, grconstr=grg, myarg, heconstr=heg, myarg,
+ compl=phiFB, gcompla=GrAphiFB, gcomplb=GrBphiFB, method="Newton",
+ control=control)
+
+ if(any(res$par[1:3] < 0) && check)
+ return(rep(NA, 3))
+ else
+ return(res$par[1:3])
+ }
+ )
+ }
>
> n <- 10
> Xinputmatrix <- t(replicate(n, unlist(myarg0) * (1 + rnorm(19, 0, .1))))
> X2inputmatrix <- t(replicate(n, unlist(myarg0) * (1 + rnorm(19, 0, .1))))
>
> Youtputs <- t(getNE(Xinputmatrix))
Error in if (any(res$par[1:3] < 0) && check) return(rep(NA, 3)) else return(res$par[1:3]) :
missing value where TRUE/FALSE needed
Calls: t -> getNE -> sapply -> lapply -> FUN
Execution halted
Flavor: r-patched-linux-x86_64