Mercurial > op > ShinyEB

changeset 9:6796c62e3a12 default tip

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
無差別曲線の説明から、エッジワースボックスの説明に入れるように機能追加
author uncorrelated zombie <uncorrelated@yahoo.co.jp>
date Wed, 21 Dec 2022 07:48:07 +0900
parents 7db5a949ba24
children
files EdgeworthBox.R ShinyEB.R
diffstat 2 files changed, 92 insertions(+), 22 deletions(-) [+]
line wrap: on
line diff
--- a/EdgeworthBox.R	Sun Oct 30 11:54:06 2022 +0900
+++ b/EdgeworthBox.R	Wed Dec 21 07:48:07 2022 +0900
@@ -1,4 +1,4 @@
-drawEdgeworthBox <- function(init_A=0.9, init_B=0.3, CC=TRUE, SHP=TRUE, IC_I=TRUE, IC_E=TRUE, CORE=TRUE, IP=TRUE){
+drawEdgeworthBox <- function(init_A=0.9, init_B=0.3, CC=TRUE, SHP=TRUE, IC_I=TRUE, IC_E=TRUE, CORE=TRUE, IP=TRUE, angle=-1*pi, prsn1=TRUE, prsn2=TRUE){
     # 経済の財は合計1に固定し、かつそれぞれの配分の最小値を0.01とする
     modifyParam <- function(g){
         g <- max(0.01, g)
@@ -79,6 +79,58 @@
     # 均衡の計算
     equilibrium <- getEquilibrium(initial_goods)
 
+    # (0.5, 0.5)を中心に、座標を回転
+    rotate  <- function(x, y){
+        rx <- x - 0.5
+        ry <- y - 0.5
+        list(x = rx*cos(angle) - ry*sin(angle) + 0.5, y = rx*sin(angle) + ry*cos(angle) + 0.5)
+    }
+
+    genv <- environment(lines)
+
+    lines <- function(x, y, ...){
+        params <- list(...)
+        r <- rotate(x, y)
+        params[["x"]] <- r$x
+        params[["y"]] <- r$y
+        do.call("lines", params, envir=genv)
+    }
+
+    text <- function(x, y, ...){
+        params <- list(...)
+        r <- rotate(x, y)
+        params[["x"]] <- r$x
+        params[["y"]] <- r$y
+        do.call("text", params, envir=genv)
+    }
+
+    polygon <- function(x, y, ...){
+        params <- list(...)
+        r <- rotate(x, y)
+        params[["x"]] <- r$x
+        params[["y"]] <- r$y
+        do.call("polygon", params, envir=genv)
+    }
+
+    arrows <- function(x0, y0, x1, y1, ...){
+        params <- list(...)
+        r0 <- rotate(x0, y0)
+        r1 <- rotate(x1, y1)
+        params[["x0"]] <- r0$x
+        params[["y0"]] <- r0$y
+        params[["x1"]] <- r1$x
+        params[["y1"]] <- r1$y
+        do.call("arrows", params, envir=genv)
+    }
+
+    points <- function(x, y, ...){
+        params <- list(...)
+        r <- rotate(x, y)
+        params[["x"]] <- r$x
+        params[["y"]] <- r$y
+        do.call("points", params, envir=genv)
+    }
+
     # 無差別曲線の描画
     drawIDC <- function(goods, lwd=c(1.5, 1.5), col=c("blue", "red", "pink"), names=NULL, IsCore=FALSE, density=10){
         UL_1 <- U_1(goods["person 1", "g/s A"], goods["person 1", "g/s B"])
@@ -113,8 +165,8 @@
             length(A), 2)
         colnames(IC_2) <- c("g/s A", "g/s B")
 
-        lines(IC_1[,"g/s B"] ~ IC_1[,"g/s A"], lwd=lwd[1], col=col[1])
-        lines(IC_2[,"g/s B"] ~ IC_2[,"g/s A"], lwd=lwd[2], col=col[2])
+        if(prsn1) lines(IC_1[,"g/s A"], IC_1[,"g/s B"], lwd=lwd[1], col=col[1])
+        if(prsn2) lines(IC_2[,"g/s A"], IC_2[,"g/s B"], lwd=lwd[2], col=col[2])
 
         if(!is.null(names)){
             # 描画域の大きさから、表示位置の調整量を決める
@@ -124,13 +176,13 @@
             b <- max(IC_1[ , "g/s B"][IC_1[ , "g/s B"] < sum_of_goods["g/s B"]], na.rm = TRUE)
             # 最大のB財に対応する行を求める
             i <- which(IC_1[ , "g/s B"]==b, arr.ind=TRUE)
-            text(IC_1[i, "g/s A"] + xadj, b, names[1], col=col[1], adj=c(0, 1))
+            if(prsn1) text(IC_1[i, "g/s A"] + xadj, b, names[1], col=col[1], adj=c(0, 1))
 
             # 枠内で最小のB財の量を求める
             b <- min(IC_2[ , "g/s B"][IC_2[ , "g/s B"] > 0], na.rm = TRUE)
             # 最小のB財に対応する行を求める
             i <- which(IC_2[ , "g/s B"]==b, arr.ind=TRUE)
-            text(IC_2[i, "g/s A"] - xadj, b, names[2], col=col[2], adj=c(1, 0))
+            if(prsn2) text(IC_2[i, "g/s A"] - xadj, b, names[2], col=col[2], adj=c(1, 0))
         }
 
         # 純粋交換経済のコア
@@ -167,19 +219,27 @@
         xlim <- c(-l/2, (1.0 + l/2))*sum_of_goods["g/s A"]
         ylim <- c(-l/2, (1.0 + l/2))*sum_of_goods["g/s B"]
 
-        arrows(0.0, 0.0, xlim[2], 0, col=col[1], lwd=lwd, length=l)
-        arrows(0.0, 0.0, 0, ylim[2], col=col[1], lwd=lwd, length=l)
+        if(prsn1){
+            arrows(0.0, 0.0, xlim[2], 0, col=col[1], lwd=lwd, length=l)
+            arrows(0.0, 0.0, 0, ylim[2], col=col[1], lwd=lwd, length=l)
+        }
 
-        arrows(sum_of_goods["g/s A"], sum_of_goods["g/s B"], sum_of_goods["g/s A"], ylim[1], col=col[2], lwd=lwd, length=l)
-        arrows(sum_of_goods["g/s A"], sum_of_goods["g/s B"], xlim[1], sum_of_goods["g/s B"], col=col[2], lwd=lwd, length=l)
+        if(prsn2){ 
+            arrows(sum_of_goods["g/s A"], sum_of_goods["g/s B"], sum_of_goods["g/s A"], ylim[1], col=col[2], lwd=lwd, length=l)
+            arrows(sum_of_goods["g/s A"], sum_of_goods["g/s B"], xlim[1], sum_of_goods["g/s B"], col=col[2], lwd=lwd, length=l)
+        }
 
-        text(0, 0, expression(O[1]), col=col[1], adj=c(1, 1))
-        text(xlim[2], 0, expression(G[1]^A), col=col[1], adj=c(0, 1))
-        text(0, ylim[2], expression(G[1]^B), col=col[1], adj=c(1, 0))
+        if(prsn1){
+            text(0, 0, expression(O[1]), col=col[1], adj=c(1, 1))
+            text(xlim[2], 0, expression(G[1]^A), col=col[1], adj=c(0, 1))
+            text(0, ylim[2], expression(G[1]^B), col=col[1], adj=c(1, 0))
+        }
 
-        text(sum_of_goods["g/s A"], sum_of_goods["g/s B"], expression(O[2]), col=col[2], adj=c(0, 0))
-        text(xlim[1], sum_of_goods["g/s B"], expression(G[2]^A), col=col[2], adj=c(1, 0))
-        text(sum_of_goods["g/s A"], ylim[1], expression(G[2]^B), col=col[2], adj=c(0, 1))
+        if(prsn2){ 
+            text(sum_of_goods["g/s A"], sum_of_goods["g/s B"], expression(O[2]), col=col[2], adj=c(0, 0))
+            text(xlim[1], sum_of_goods["g/s B"], expression(G[2]^A), col=col[2], adj=c(1, 0))
+            text(sum_of_goods["g/s A"], ylim[1], expression(G[2]^B), col=col[2], adj=c(0, 1))
+        }
     })
 
     # 契約曲線の計算と描画
--- a/ShinyEB.R	Sun Oct 30 11:54:06 2022 +0900
+++ b/ShinyEB.R	Wed Dec 21 07:48:07 2022 +0900
@@ -4,10 +4,11 @@
 loadLib("nleqslv", "shiny")
 
 ui <- fluidPage(
+    # theme = bslib::bs_theme(bootswatch = "minty"),
     titlePanel("Edgeworth Box"),
 
-    sidebarLayout(
-        sidebarPanel(
+    fluidRow(
+        column(3, 
             sliderInput("A",
                 "initial amount of goods A of person 1",
                 min = 0.01,
@@ -32,10 +33,19 @@
             checkboxInput("isIC_E", "Indiffrent Curves pass through the Equilibrium", TRUE),
             checkboxInput("isSHP", "Separating Hyperplane", TRUE),
             checkboxInput("isCC", "Contract Curve", TRUE)
-        ), 
-
-        mainPanel(
-            plotOutput("distPlot")
+        ),
+        column(4, 
+            plotOutput("distPlot"),
+        ),
+        column(3, 
+            sliderInput("angle",
+                "angle of rotation",
+                min = -180,
+                max = 0,
+                value = 0,
+                width = "50%"),
+            checkboxInput("prsn1", "Show properties of Person 1", TRUE),
+            checkboxInput("prsn2", "Show properties of Person 2", TRUE)
         )
     )
 )
@@ -49,7 +59,7 @@
     output$distPlot <- renderPlot({
         # inputはReactiveValuesクラスで$で参照できる変数を陽に持たないため、withやattachが使えない
         drawEdgeworthBox(input$A, input$B, CC=input$isCC, SHP=input$isSHP, IC_I=input$isIC_I,
-            IC_E=input$isIC_E, CORE=input$isCore, IP=input$isIP)
+            IC_E=input$isIC_E, CORE=input$isCore, IP=input$isIP, angle=input$angle/180*pi, prsn1=input$prsn1, prsn2=input$prsn2)
     }, width=500, height=500)
 }