├── .Rbuildignore
├── .gitignore
├── DESCRIPTION
├── LICENSE
├── LICENSE.md
├── NAMESPACE
├── R
├── demand.R
├── econocharts-package.R
├── globals.R
├── indiference.R
├── intersect.R
├── laffer.R
├── neolabsup.R
├── ppf.R
├── ptvalue.R
├── sdcurve.R
├── supply.R
├── tax.R
└── zzz.R
├── README.md
├── econocharts.Rproj
└── man
├── curve_intersect.Rd
├── demand.Rd
├── econocharts-package.Rd
├── indifference.Rd
├── laffer.Rd
├── neolabsup.Rd
├── ppf.Rd
├── ptvalue.Rd
├── sdcurve.Rd
├── supply.Rd
└── tax_graph.Rd
/.Rbuildignore:
--------------------------------------------------------------------------------
1 | ^.*\.Rproj$
2 | ^\.Rproj\.user$
3 |
--------------------------------------------------------------------------------
/.gitignore:
--------------------------------------------------------------------------------
1 | .Rproj.user
2 | .Rhistory
3 | .RData
4 | .Ruserdata
5 |
--------------------------------------------------------------------------------
/DESCRIPTION:
--------------------------------------------------------------------------------
1 | Package: econocharts
2 | Title: Microeconomics and Macroeconomics Charts Made with 'ggplot2'
3 | Version: 1.0
4 | Authors@R: c(
5 | person("José Carlos", "Soage González", email = "jsoage@uvigo.es", role = c("aut", "cre")),
6 | person("Andrew", "Heiss", email = "andrewheiss@gmail.com", role = "aut"))
7 | Description: Contains several functions for creating fully-customizable microeconomics or macroeconomics charts, such as supply and demand curves, indifference curves, production-possibility frontiers or Laffer curves.
8 | Imports: ggplot2, dplyr, Hmisc, scales, glue
9 | License: MIT + file LICENSE
10 | Encoding: UTF-8
11 | URL: https://r-coder.com/, https://r-coder.com/economics-charts-r/
12 | LazyData: true
13 | Roxygen: list(markdown = TRUE)
14 | RoxygenNote: 7.1.1
15 |
--------------------------------------------------------------------------------
/LICENSE:
--------------------------------------------------------------------------------
1 | YEAR: 2020
2 | COPYRIGHT HOLDER: José Carlos Soage González
3 |
--------------------------------------------------------------------------------
/LICENSE.md:
--------------------------------------------------------------------------------
1 | # MIT License
2 |
3 | Copyright (c) 2020 José Carlos Soage González
4 |
5 | Permission is hereby granted, free of charge, to any person obtaining a copy
6 | of this software and associated documentation files (the "Software"), to deal
7 | in the Software without restriction, including without limitation the rights
8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
9 | copies of the Software, and to permit persons to whom the Software is
10 | furnished to do so, subject to the following conditions:
11 |
12 | The above copyright notice and this permission notice shall be included in all
13 | copies or substantial portions of the Software.
14 |
15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
21 | SOFTWARE.
22 |
23 |
24 |
25 | # MIT License
26 |
27 | Copyright (c) 2017 Andrew Heiss
28 |
29 | Permission is hereby granted, free of charge, to any person obtaining a copy
30 | of this software and associated documentation files (the "Software"), to deal
31 | in the Software without restriction, including without limitation the rights
32 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
33 | copies of the Software, and to permit persons to whom the Software is
34 | furnished to do so, subject to the following conditions:
35 |
36 | The above copyright notice and this permission notice shall be included in all
37 | copies or substantial portions of the Software.
38 |
39 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
40 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
41 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
42 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
43 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
44 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
45 | SOFTWARE.
46 |
--------------------------------------------------------------------------------
/NAMESPACE:
--------------------------------------------------------------------------------
1 | # Generated by roxygen2: do not edit by hand
2 |
3 | export(curve_intersect)
4 | export(demand)
5 | export(indifference)
6 | export(laffer)
7 | export(neolabsup)
8 | export(ppf)
9 | export(ptvalue)
10 | export(sdcurve)
11 | export(supply)
12 | export(tax_graph)
13 | import(dplyr)
14 | import(ggplot2)
15 | importFrom(stats,approxfun)
16 | importFrom(stats,uniroot)
17 |
--------------------------------------------------------------------------------
/R/demand.R:
--------------------------------------------------------------------------------
1 | #' @title demand curves
2 | #'
3 | #' @description TODO
4 | #'
5 | #' @param ... Specify the demand curve or curves separated by commas (as `data.frame`) you want to display in the graph. This will override the sample curve.
6 | #' @param ncurves Number of demand curves to be generated based on the sample data.
7 | #' @param xmax Numeric. Allows modifying the maximum X value for the default demand function.
8 | #' @param ymax Numeric. Allows modifying the maximum Y value for the default demand function.
9 | #' @param type Possible values are `"convex"` (default) and `"line"` to plot a convex or a linear demand function by default, respectively.
10 | #' @param x Y-axis values where to create intersections with the demand curves.
11 | #' @param curve_names Boolean. If `TRUE`, the function adds default names to each.
12 | #' @param names If `curve_names = TRUE` are custom names for the curves.
13 | #' @param linecol Line color of the curves.
14 | #' @param labels If `x` is specified, are the labels for the intersection points.
15 | #' @param generic Boolean. If `TRUE` and `x` is specified, the axis labels shows generic names. If `FALSE`, the axis labels are the actual data of the axis that corresponds to the intersection points.
16 | #' @param geom Possible values are `"text"` to display the labels of the intersection points with text and `"label"` to show them with labels.
17 | #' @param geomcol Color of the labels of the intersection points.
18 | #' @param geomfill If `geom = "label"` is the background color of the label.
19 | #' @param main Main title of the plot.
20 | #' @param sub Subtitle of the plot.
21 | #' @param xlab Name of the X-axis.
22 | #' @param ylab Name of the Y-axis.
23 | #' @param bg.col Background color of the plot.
24 | #' @import ggplot2 dplyr
25 | #' @export
26 | demand <- function(...,
27 | ncurves = 1,
28 | # distance = 1,
29 | xmax,
30 | ymax,
31 | type = "convex",
32 | x,
33 | curve_names = TRUE,
34 | names, # Names of the demand curves
35 | linecol,
36 | labels, # Label points
37 | generic = TRUE,
38 | geom = "text",
39 | geomcol = 1,
40 | geomfill = "white",
41 | main = NULL,
42 | sub = NULL,
43 | xlab = NULL,
44 | ylab = NULL,
45 | bg.col = "white") {
46 |
47 | if(!missing(labels)){
48 |
49 | if(length(labels) == 1) {
50 | if(labels == "") {
51 | labels <- rep("", length(x))
52 | }
53 | }
54 |
55 | if(length(labels) != length(x)) {
56 | warning(paste("The number of labels provided must be equal to the intersections, so length(labels) must be:", length(x) * ncurves))
57 | }
58 |
59 | }
60 |
61 | m <- FALSE
62 |
63 | if(missing(...)){
64 | ncurve <- ncurves
65 |
66 | if(missing(xmax)){
67 | xmax <- 9
68 | }
69 |
70 | if(missing(ymax)){
71 | ymax <- 9
72 | }
73 |
74 | if(type == "convex") {
75 | # Sample indifference curve
76 | curve <- data.frame(Hmisc::bezier(c(1, 3, xmax),
77 | c(ymax, 3, 1)))
78 |
79 | m <- TRUE
80 | }
81 |
82 | if(type == "line") {
83 | curve <- data.frame(x = c(0.9, xmax),
84 | y = c(ymax, 0.9))
85 | m <- TRUE
86 | }
87 | } else{
88 | curve <- list(...)
89 | ncurve <- length(curve)
90 |
91 | class <- vector("character", ncurve)
92 |
93 | for(i in 1:ncurve) {
94 |
95 | class[i] <- class(curve[[i]])
96 |
97 | }
98 |
99 | if(any(class != "data.frame")) {
100 | stop("You can only pass data frames to the '...' argument")
101 | }
102 |
103 | if(ncurve == 1){
104 | m <- TRUE
105 | }
106 | }
107 |
108 | if(missing(linecol)){
109 |
110 | if(missing(...)){
111 | linecol <- 1
112 | }
113 |
114 | if(!missing(...) & ncurve == 1){
115 | linecol <- 1
116 | }
117 |
118 | if(!missing(...) & ncurve > 1){
119 | linecol <- rep(1, ncurve)
120 | }
121 | } else {
122 |
123 | if(!missing(...) & length(linecol) == 1){
124 | linecol <- rep(linecol, ncurve)
125 | }
126 | }
127 |
128 | if(!missing(x)){
129 |
130 | if(any(x < 0) | any(x > max(data.frame(curve)$y))) {
131 | warning("There are values on the 'x' argument lower than 0 or greater than the maximun value of the curve")
132 | x <- x[x <= max(data.frame(curve)$y)]
133 | }
134 |
135 | # Calculate the intersections of the curves
136 | intersections <- tibble()
137 |
138 | if((missing(...) | length(curve) == 1) & ncurves == 1) {
139 |
140 | for(i in 1:length(x)) {
141 | intersections <- intersections %>%
142 | bind_rows(curve_intersect(data.frame(x = c(0, 10000), y = rep(x[i], 2)), data.frame(curve)))
143 |
144 | }
145 | } else {
146 |
147 | intersections <- vector("list", ncurve)
148 |
149 | if(ncurves > 1) {
150 |
151 | if(length(x) == 1) {
152 | w <- 0
153 | for(i in 1:ncurve){
154 |
155 | for(j in 1:length(x)) {
156 |
157 | intersections[[i]][[j]] <- bind_rows(curve_intersect(data.frame(x = 1:1000, y = rep(x[j], nrow(curve))), data.frame(x = curve$x + w, y = curve$y)))
158 | w <- w + 1
159 | }
160 | }
161 |
162 | intersections <- bind_rows(intersections)
163 | } else {
164 | stop("Multiple intersections with ncurves > 1 is not implemented yet")
165 | }
166 |
167 | } else {
168 |
169 | for(i in 1:ncurve){
170 |
171 | for(j in 1:length(x)) {
172 |
173 | intersections[[i]][[j]] <- bind_rows(curve_intersect(data.frame(x = 1:1000, y = rep(x[j], nrow(curve[[1]]))), curve[[i]]))
174 | }
175 | }
176 |
177 | intersections <- bind_rows(intersections)
178 |
179 | }
180 | }
181 | # print(intersections)
182 | }
183 |
184 | if(missing(labels) & !missing(x)){
185 | labels <- LETTERS[1:nrow(intersections)]
186 | }
187 |
188 | p <- ggplot(mapping = aes(x = x, y = y))
189 |
190 |
191 | if(missing(...) | m){
192 |
193 | for(i in 0:(ncurves - 1)) {
194 | p <- p + geom_line(data = data.frame(x = curve$x + i, y = curve$y), color = linecol, size = 1, linetype = 1)
195 | }
196 |
197 | } else {
198 |
199 | for(i in 1:length(curve)) {
200 | p <- p + geom_line(data = data.frame(curve[[i]]), color = linecol[i], size = 1, linetype = 1)
201 | }
202 | }
203 |
204 | if(curve_names == TRUE) {
205 |
206 | if(ncurves == 1) {
207 |
208 | if(missing(names)) {
209 | names <- "D"
210 | }
211 |
212 | p <- p + annotate(geom = "text", x = max(as.data.frame(curve)$x) + 0.5, y = min(as.data.frame(curve)$y), label = names, parse = TRUE,
213 | size = 4, color = geomcol)
214 | } else {
215 |
216 | if(missing(names)) {
217 | names <- sapply(1:ncurves, function(i) paste0("D[", i, "]"))
218 | }
219 |
220 | j <- 0
221 | for(i in 1:ncurves){
222 | p <- p + annotate(geom = "text", x = max(as.data.frame(curve)$x) + j + 0.35, y = min(as.data.frame(curve)$xy), label = names[i], parse = TRUE,
223 | size = 4, color = geomcol)
224 | j <- j + 1
225 | }
226 | }
227 |
228 | }
229 |
230 | if(!missing(x)) {
231 | p <- p + geom_segment(data = intersections,
232 | aes(x = x, y = 0, xend = x, yend = y), lty = "dotted") +
233 |
234 | geom_segment(data = intersections,
235 | aes(x = 0, y = y, xend = x, yend = y), lty = "dotted") +
236 | geom_point(data = intersections, size = 3)
237 |
238 |
239 | if(geom == "label") {
240 | for(i in 1:nrow(intersections)){
241 |
242 | p <- p + annotate(geom = "label", x = unlist(intersections[1][i, ]) + 0.35, y = unlist(intersections[2][i, ]), label = labels[i],
243 | size = 4, fill = geomfill, color = geomcol)
244 | }
245 | }
246 |
247 | if(geom == "text") {
248 |
249 | for(i in 1:nrow(intersections)){
250 |
251 | p <- p + annotate(geom = "text", x = unlist(intersections[1][i, ]) + 0.35, y = unlist(intersections[2][i, ]), label = labels[i],
252 | size = 4, color = geomcol)
253 | }
254 | }
255 |
256 | if(generic == FALSE) {
257 |
258 | p <- p + scale_x_continuous(expand = c(0, 0), limits = c(0, max(unlist(curve)) + ncurves),
259 | breaks = intersections$x, labels = round(intersections$x, 2)) +
260 | scale_y_continuous(expand = c(0, 0), limits = c(0, max(unlist(curve)) + 1),
261 | breaks = unique(round(intersections$y, 2)), labels = unique(round(intersections$y, 2)))
262 |
263 | } else {
264 |
265 | if(ncurve == 1 & missing(...)){
266 |
267 | p <- p + scale_x_continuous(expand = c(0, 0), limits = c(0, max(unlist(curve)) + ncurves),
268 | breaks = intersections$x, labels = sapply(length(x):1, function(i) as.expression(bquote(X[.(LETTERS[i])])))) +
269 | scale_y_continuous(expand = c(0, 0), limits = c(0, max(unlist(curve)) + ncurves),
270 | breaks = round(intersections$y, 2), labels = sapply(length(x):1, function(i) as.expression(bquote(Y[.(LETTERS[i])]))))
271 | } else {
272 |
273 | labels <- rev(sapply(length(intersections$x):1, function(i) as.expression(bquote(P[.(LETTERS[i])]))))
274 |
275 | p <- p + scale_x_continuous(expand = c(0, 0), limits = c(0, max(unlist(curve)) + ncurves),
276 | breaks = intersections$x, labels = labels) +
277 | scale_y_continuous(expand = c(0, 0), limits = c(0, max(unlist(curve)) + ncurves),
278 | breaks = x, labels = sapply(length(x):1, function(i) as.expression(bquote(Q[.(LETTERS[i])]))))
279 | }
280 |
281 | }
282 | } else {
283 | p <- p + scale_x_continuous(expand = c(0, 0), limits = c(0, max(unlist(curve)) + ncurves)) +
284 | scale_y_continuous(expand = c(0, 0), limits = c(0, max(unlist(curve)) + ncurves))
285 | }
286 |
287 | p <- p + labs(x = xlab, y = ylab, title = main, subtitle = sub)
288 |
289 | p <- p +
290 | # coord_equal() +
291 | theme_classic() +
292 | theme(plot.title = element_text(size = rel(1.3)),
293 | # axis.text.x = element_text(colour = linecol),
294 | axis.title.y = element_text(margin = margin(t = 0, r = 10, b = 0, l = 0), angle = 0, vjust = 1),
295 | axis.title.x = element_text(margin = margin(t = 0, r = 25, b = 0, l = 0), angle = 0, hjust = 1),
296 | plot.background = element_rect(fill = bg.col),
297 | plot.margin = margin(0.5, 1, 0.5, 0.5, "cm"))
298 |
299 | if(!missing(x)){
300 | return(list(p = p, intersections = intersections, curve = curve))
301 | } else {
302 | return(list(p = p, curve = curve))
303 | }
304 | }
305 |
306 |
--------------------------------------------------------------------------------
/R/econocharts-package.R:
--------------------------------------------------------------------------------
1 | #' @title econocharts: Microeconomics and Macroeconomics charts Made with 'ggplot2'
2 | #'
3 | #' @description This package allows creating microeconomics and macroeconomics charts, like supply and demand curves, production-possibility frontiers, indifference curves, Laffer curves or customized charts with very simple functions.
4 | #'
5 | #' @details
6 | #' \itemize{
7 | #' \item{Package: econocharts}
8 | #' \item{Version: 1.0}
9 | #' \item{Maintainer: José Carlos Soage González \email{jsoage@@uvigo.es}}
10 | #' }
11 | #'
12 | #' @author
13 | #' \itemize{
14 | #' \item{Soage González, José Carlos.}
15 | #' \item{Weiss, Andrew.}
16 | #' }
17 | #'
18 | #' @seealso
19 | #' \itemize{
20 | #' \item{\href{https://r-coder.com/}{R tutorials}}
21 | #' }
22 | #'
23 | #' @docType package
24 | #' @name econocharts-package
25 | NULL
26 |
--------------------------------------------------------------------------------
/R/globals.R:
--------------------------------------------------------------------------------
1 | utils::globalVariables(c("x", "y", "text", "fill", "lab", "ticks", "zero"))
2 |
--------------------------------------------------------------------------------
/R/indiference.R:
--------------------------------------------------------------------------------
1 | #' @title Indifference curves
2 | #'
3 | #' @description TODO
4 | #'
5 | #' @param ... Specify the curve or curves separated by commas (as `data.frame`) you want to display in the graph. This will override the sample curve.
6 | #' @param ncurves If `...` is not specified, is the number of indifference curves to be generated based on the sample data.
7 | #' @param xmax Numeric. Allows modifying the maximum X value for the default indifference function.
8 | #' @param ymax Numeric. Allows modifying the maximum Y value for the default indifference function.
9 | #' @param type Possible values are `"normal`, for a normal indifference function, `"psubs"` for perfect substitute and `"pcom"` for perfect complements.
10 | #' @param x Y-axis values where to create intersections with the indifference curves.
11 | #' @param pointcol If `x` is specified, is the color of the points that represents the intersections.
12 | #' @param curve_names Boolean. If `TRUE`, the function adds default names to each.
13 | #' @param names If `curve_names = TRUE` are custom names for the curves.
14 | #' @param linecol Line color of the curves.
15 | #' @param labels If `x` is specified are the labels for the intersection points.
16 | #' @param generic Boolean. If `TRUE` and `x` is specified, the axis labels shows generic names. If `FALSE`, the axis labels are the actual data of the axis that corresponds to the intersection points.
17 | #' @param geom Possible values are `"text"` to display the labels of the intersection points with text and `"label"` to show them with labels.
18 | #' @param geomcol Color of the labels of the intersection points.
19 | #' @param geomfill If `geom = "label"` is the background color of the label.
20 | #' @param main Main title of the plot.
21 | #' @param sub Subtitle of the plot.
22 | #' @param xlab Name of the X-axis.
23 | #' @param ylab Name of the Y-axis.
24 | #' @param bg.col Background color of the plot.
25 | #' @import ggplot2 dplyr
26 | #' @export
27 | indifference <- function(...,
28 | ncurves = 1,
29 | xmax,
30 | ymax,
31 | type = "normal",
32 | x,
33 | pointcol = 1,
34 | curve_names = TRUE,
35 | names,
36 | linecol,
37 | labels,
38 | generic = TRUE,
39 | geom = "text",
40 | geomcol = 1,
41 | geomfill = "white",
42 | main = NULL,
43 | sub = NULL,
44 | xlab = NULL,
45 | ylab = NULL,
46 | bg.col = "white"){
47 |
48 | m <- FALSE
49 |
50 | match.arg(type, choices = c("normal", "psubs", "pcom"))
51 |
52 | if(missing(...)){
53 | ncurve <- ncurves
54 |
55 | if(missing(xmax)){
56 | xmax <- 9
57 | }
58 |
59 | if(missing(ymax)){
60 | ymax <- 9
61 | }
62 |
63 | if(type == "normal") {
64 | # Example indifference curve
65 | curve <- data.frame(Hmisc::bezier(c(0.9, xmax - 6, xmax),
66 | c(ymax, ymax - 6, 0.9)))
67 |
68 | m <- TRUE
69 | }
70 |
71 | if(type == "psubs") {
72 | curve <- data.frame(x = c(0.9, xmax),
73 | y = c(ymax, 0.9))
74 | m <- TRUE
75 | }
76 |
77 | if(type == "pcom") {
78 | curve <- data.frame(x = c(rep(0.9, 10), seq(0.9, 9, length.out = 10)),
79 | y = c(seq(0.9, 9, length.out = 10), rep(0.9, 10)))
80 | m <- TRUE
81 | }
82 |
83 | } else{
84 |
85 | curve <- list(...)
86 |
87 | class <- vector("character", length(curve))
88 |
89 | for(i in 1:length(curve)) {
90 |
91 | class[i] <- class(curve[[i]])
92 |
93 | }
94 |
95 | if(any(class != "data.frame")) {
96 | stop("You can only pass data frames to the '...' argument")
97 | }
98 |
99 |
100 | ncurve <- length(curve)
101 | if(ncurve == 1){
102 | m <- TRUE
103 | }
104 | }
105 |
106 | if(missing(names)) {
107 | names <- sapply(1:ncurves, function(i) paste0("I[", i, "]"))
108 | }
109 |
110 | if(missing(linecol)){
111 |
112 | if(missing(...)){
113 | linecol <- 1
114 | }
115 |
116 | if(!missing(...) & ncurve == 1){
117 | linecol <- 1
118 | }
119 |
120 | if(!missing(...) & ncurve > 1){
121 | linecol <- rep(1, ncurve)
122 | }
123 | } else {
124 |
125 | if(!missing(...) & length(linecol) == 1){
126 | linecol <- rep(linecol, ncurve)
127 | } else {
128 |
129 | # linecols <- vector("list", length = ncurves)
130 | #
131 | # for(i in 1:ncurves){
132 | # linecols[[i]] <- rep(linecol[i], nrow(curve)/ ncurves)
133 | # }
134 | #
135 | # linecol <- unlist(linecols)
136 |
137 | }
138 | }
139 |
140 | if(missing(labels) & !missing(x)){
141 | labels <- LETTERS[1:length(x)]
142 | }
143 |
144 | if(!missing(x)){
145 |
146 | if(any(x < 0) | any(x > max(data.frame(curve)$y))) {
147 | warning("There are values on the 'x' argument lower than 0 or greater than the maximun value of the curve")
148 | x <- x[x <= max(data.frame(curve)$y)]
149 | }
150 |
151 |
152 | if(type == "pcom") {
153 | warning("Intersections not available for perfect complements. Please add the points manually")
154 | } else {
155 | # Calculate the intersections of the curves
156 | intersections <- tibble()
157 |
158 | if(missing(...) | length(curve) == 1) {
159 |
160 | for(i in 1:length(x)) {
161 | intersections <- intersections %>%
162 | bind_rows(curve_intersect(data.frame(x = c(0, 10000), y = rep(x[i], 2)), data.frame(curve)))
163 |
164 | }
165 | } else {
166 |
167 | intersections <- vector("list", ncurve)
168 | for(i in 1:ncurve){
169 |
170 | for(j in 1:length(x)) {
171 |
172 | intersections[[i]][[j]] <- bind_rows(curve_intersect(data.frame(x = 1:1000, y = rep(x[j], nrow(curve[[1]]))), curve[[i]]))
173 | }
174 |
175 | }
176 | intersections <- bind_rows(intersections)
177 | }
178 | # print(intersections)
179 | }
180 | }
181 |
182 | p <- ggplot(mapping = aes(x = x, y = y))
183 |
184 |
185 | if(missing(...) | m){
186 |
187 | for(i in 0:(ncurves - 1)) {
188 | p <- p + geom_line(data = data.frame(curve) + i, color = linecol, size = 1, linetype = 1)
189 | }
190 |
191 | } else {
192 |
193 | for(i in 1:length(curve)) {
194 | p <- p + geom_line(data = data.frame(curve[[i]]), color = linecol[i], size = 1, linetype = 1)
195 | }
196 | }
197 |
198 | if(curve_names == TRUE) {
199 |
200 | if(ncurves == 1) {
201 | p <- p + annotate(geom = "text", x = max(as.data.frame(curve)$x) + 0.5, y = min(as.data.frame(curve)$y), label = "I",
202 | size = 4, color = geomcol)
203 | } else {
204 |
205 | j <- 0
206 | for(i in 1:ncurves){
207 | p <- p + annotate(geom = "text", x = max(as.data.frame(curve)$x) + j + 0.5, y = min(as.data.frame(curve)$y) + j, label = names[i], parse = TRUE,
208 | size = 4, color = geomcol)
209 | j <- j + 1
210 | }
211 | }
212 |
213 | }
214 |
215 | if(!missing(x) & type != "pcom"){
216 |
217 | p <- p + geom_segment(data = intersections,
218 | aes(x = x, y = 0, xend = x, yend = y), lty = "dotted") +
219 |
220 | geom_segment(data = intersections,
221 | aes(x = 0, y = y, xend = x, yend = y), lty = "dotted") +
222 | geom_point(data = intersections, size = 3, color = pointcol)
223 |
224 |
225 | if(geom == "label") {
226 | for(i in 1:length(x)){
227 |
228 | p <- p + annotate(geom = "label", x = unlist(intersections[1][i, ]) + 0.25, y = unlist(intersections[2][i, ]) + 0.25, label = rev(labels)[i],
229 | size = 4, fill = "white", color = geomcol)
230 | }
231 | }
232 |
233 | if(geom == "text") {
234 | for(i in 1:length(x)){
235 |
236 | p <- p + annotate(geom = "text", x = unlist(intersections[1][i, ]) + 0.25, y = unlist(intersections[2][i, ]) + 0.25, label = rev(labels)[i],
237 | size = 4, color = geomcol)
238 | }
239 | }
240 |
241 | if(generic == FALSE) {
242 | p <- p + scale_x_continuous(expand = c(0, 0), limits = c(0, max(unlist(curve)) + 1), breaks = intersections$x, labels = round(intersections$x, 2)) +
243 | scale_y_continuous(expand = c(0, 0), limits = c(0, max(unlist(curve)) + 1), breaks = intersections$y, labels = round(intersections$y, 2))
244 | } else {
245 |
246 | if(ncurve == 1 | missing(...)){
247 |
248 | p <- p + scale_x_continuous(expand = c(0, 0), limits = c(0, max(unlist(curve)) + ncurves),
249 | breaks = intersections$x, labels = sapply(length(x):1, function(i) as.expression(bquote(X[.(LETTERS[i])])))) +
250 | scale_y_continuous(expand = c(0, 0), limits = c(0, max(unlist(curve)) + ncurves),
251 | breaks = intersections$y, labels = sapply(length(x):1, function(i) as.expression(bquote(Y[.(LETTERS[i])]))))
252 | } else {
253 |
254 | labels <- sapply(length(intersections$x):1, function(i) as.expression(bquote(X[.(LETTERS[i])])))
255 |
256 | p <- p + scale_x_continuous(expand = c(0, 0), limits = c(0, max(unlist(curve)) + ncurves),
257 | breaks = intersections$x, labels = labels) +
258 | scale_y_continuous(expand = c(0, 0), limits = c(0, max(unlist(curve)) + ncurves),
259 | breaks = x, labels = sapply(length(x):1, function(i) as.expression(bquote(Y[.(LETTERS[i])]))))
260 | }
261 |
262 | }
263 | } else {
264 | p <- p + scale_x_continuous(expand = c(0, 0), limits = c(0, max(unlist(curve)) + ncurves)) +
265 | scale_y_continuous(expand = c(0, 0), limits = c(0, max(unlist(curve)) + ncurves))
266 | }
267 |
268 | p <- p + labs(x = xlab, y = ylab, title = main, subtitle = sub)
269 |
270 | p <- p +
271 | # coord_equal() +
272 | theme_classic() +
273 | theme(plot.title = element_text(size = rel(1.3)),
274 | # axis.text.x = element_text(colour = linecol),
275 | axis.title.y = element_text(margin = margin(t = 0, r = 10, b = 0, l = 0), angle = 0, vjust = 1),
276 | axis.title.x = element_text(margin = margin(t = 0, r = 25, b = 0, l = 0), angle = 0, hjust = 1),
277 | plot.background = element_rect(fill = bg.col),
278 | plot.margin = margin(0.5, 1, 0.5, 0.5, "cm"))
279 |
280 | if(!missing(x)){
281 | return(list(p = p, intersections = intersections, curve = curve))
282 | } else {
283 | return(list(p = p, curve = curve))
284 | }
285 | }
286 |
--------------------------------------------------------------------------------
/R/intersect.R:
--------------------------------------------------------------------------------
1 | #' @title Intersection of two curves
2 | #'
3 | #' @description Calculate where two lines or curves intersect. Curves are defined as data
4 | #' frames with x and y columns providing cartesian coordinates for the lines.
5 | #' This function works on both linear and nonlinear curves.
6 | #'
7 | #' @param curve1 Either a \code{data.frame} with columns named \code{x} and \code{y} or a function.
8 | #' @param curve2 Either \code{data.frame} with columns named \code{x} and \code{y} or a function.
9 | #' @param empirical If true (default) indicates that the curves are data frames of empirical data. If false, indicates that the curves are actual functions.
10 | #' @param domain Two-value numeric vector indicating the bounds along the x-axis where the intersection should be found when \code{empirical} is false
11 | #'
12 | #' @details For now, \code{curve_intersect} will only find one intersection.
13 | #'
14 | #' If you define curves with empirical data frames (i.e. provide actual values
15 | #' for x and y), ensure that \code{empirical = TRUE}.
16 | #'
17 | #' If you define curves with functions (i.e. \code{curve1 <- x^2}), ensure that
18 | #' \code{empirical = FALSE} and provide a range of x-axis values to search for
19 | #' an intersection using \code{domain}.
20 | #'
21 | #' @return A list with \code{x} and \code{y} values.
22 | #'
23 | #' @author
24 | #' \itemize{
25 | #' \item{Weiss, Andrew.}
26 | #' }
27 | #'
28 | #' @importFrom stats approxfun uniroot
29 | #'
30 | #' @examples
31 | #' # Straight lines (empirical)
32 | #' line1 <- data.frame(x = c(1, 9), y = c(1, 9))
33 | #' line2 <- data.frame(x = c(9, 1), y = c(1, 9))
34 | #'
35 | #' curve_intersect(line1, line2)
36 | #'
37 | #' # Curved lines (empirical)
38 | #' curve1 <- data.frame(Hmisc::bezier(c(1, 8, 9), c(1, 5, 9)))
39 | #' curve2 <- data.frame(Hmisc::bezier(c(1, 3, 9), c(9, 3, 1)))
40 | #'
41 | #' curve_intersect(curve1, curve2)
42 | #'
43 | #' # Curved lines (functional)
44 | #' curve1 <- function(q) (q - 10)^2
45 | #' curve2 <- function(q) q^2 + 2*q + 8
46 | #'
47 | #' curve_intersect(curve1, curve2, empirical = FALSE, domain = c(0, 5))
48 | #' @export
49 | curve_intersect <- function(curve1, curve2, empirical = TRUE, domain = NULL) {
50 | if (!empirical & missing(domain)) {
51 | stop("'domain' must be provided with non-empirical curves")
52 | }
53 |
54 | if (!empirical & (length(domain) != 2 | !is.numeric(domain))) {
55 | stop("'domain' must be a two-value numeric vector, like c(0, 10)")
56 | }
57 |
58 | if (empirical) {
59 |
60 | # Approximate the functional form of both curves
61 | curve1_f <- approxfun(curve1$x, curve1$y, rule = 2)
62 | curve2_f <- approxfun(curve2$x, curve2$y, rule = 2)
63 |
64 | # Calculate the intersection of curve 1 and curve 2 along the x-axis
65 | point_x <- uniroot(function(x) curve1_f(x) - curve2_f(x),
66 | c(min(curve1$x), max(curve1$x)))$root
67 |
68 | # Find where point_x is in curve 2
69 | point_y <- curve2_f(point_x)
70 | } else {
71 | # Calculate the intersection of curve 1 and curve 2 along the x-axis
72 | # within the given domain
73 | point_x <- uniroot(function(x) curve1(x) - curve2(x), domain)$root
74 |
75 | # Find where point_x is in curve 2
76 | point_y <- curve2(point_x)
77 | }
78 | # }
79 |
80 | return(list(x = point_x, y = point_y))
81 | }
82 |
83 |
84 | # APROXIMAR CUANDO LA LINEA ES VERTICAL
85 |
86 |
87 | # linerect <- data.frame(x = c(5,5), y = c(0, 9))
88 | #
89 | # line3 <- data.frame(x = c(2, 10), y = c(1, 9))
90 | #
91 | #
92 | # curve_intersect(linerect, line3) # No va
93 | #
94 | # plot(linerect, type = "l")
95 | # lines(line3, type = "l", col = 2)
96 | #
97 | # AF2 = approxfun(line3$x, line3$y)
98 | # AF2(5)
99 |
100 |
101 | # line <- data.frame(x = 0:10, y = rep(3, 11))
102 | # lines(line)
103 | # curve_intersect(line, curve)
104 | #
105 | #
106 | #
107 | # curve <- data.frame(Hmisc::bezier(c(1, 9, 2),
108 | # c(1, 5, 9)))
109 | # line <- data.frame(x = 0:10, y = rep(3, 11))
110 | #
111 | # plot(curve$x, curve$y, type = "l")
112 | # lines(line)
113 | #
114 | #
115 | # int <- curve_intersect(curve, line)
116 | # abline(v = int$x)
117 | #
118 | # ggplot(curve, aes(x = x, y = y)) +
119 | # geom_line() +
120 | # geom_path()
121 |
--------------------------------------------------------------------------------
/R/laffer.R:
--------------------------------------------------------------------------------
1 | #' @title Laffer curve
2 | #'
3 | #' @description Creates Laffer curves. The function allows specifying a custom Laffer curve, modifying the maximum X and Y axis values, creating intersections along the values of the Y-axis and the curve and customizing the final output with other arguments.
4 | #'
5 | #' @param curve Specify a custom curve (as `data.frame`). This will override the sample curve.
6 | #' @param t Y-axis values where to create intersections with the Laffer curve.
7 | #' @param xmax Numeric. Allows modifying the maximum X value for the default Laffer curve.
8 | #' @param ymax Numeric. Allows modifying the maximum Y value for the default Laffer curve.
9 | #' @param pointcol Color of the point that represents the optimum point.
10 | #' @param generic Boolean. If `TRUE` and `x` is specified, the axis labels shows generic names. If `FALSE`, the axis labels are the actual data of the axis that corresponds to the intersection points and the optimal point.
11 | #' @param showmax If `TRUE`, shows the optimal point.
12 | #' @param main Main title of the plot.
13 | #' @param sub Subtitle of the plot.
14 | #' @param xlab Name of the X-axis.
15 | #' @param ylab Name of the Y-axis.
16 | #' @param acol Color of the area of the curve.
17 | #' @param alpha Transparency of the colored area.
18 | #' @param bg.col Background color of the plot.
19 | #' @import ggplot2 dplyr
20 | #' @export
21 | laffer <- function(curve, t, xmax, ymax, pointcol = 1, generic = TRUE, showmax = TRUE,
22 | main = NULL, sub = NULL, xlab = NULL, ylab = NULL, acol, alpha = 0.3, bg.col = "white"){
23 |
24 | if(missing(ymax)) {
25 | ymax <- 5
26 | }
27 |
28 | if(missing(xmax)) {
29 | xmax <- 10
30 | }
31 |
32 | if(ymax > xmax) {
33 | stop("'ymax' must be lower or equal to 'xmax'")
34 | }
35 |
36 | if(missing(curve)){
37 |
38 | # Example laffer curve
39 | curve <- data.frame(Hmisc::bezier(c(0, ymax, xmax),
40 | c(0, xmax + 0.1, 0)))
41 | }
42 |
43 | if(!missing(t)){
44 |
45 | if(any(t < 0) | any(t > max(data.frame(curve)$y))) {
46 | warning("There are values on the 't' argument lower than 0 or greater than the maximun value of the curve")
47 | t <- t[t <= max(data.frame(curve)$y)]
48 | }
49 |
50 | # Calculate the intersections of the curves
51 | intersections <- tibble()
52 |
53 | for(i in 1:length(t)) {
54 | intersections <- intersections %>%
55 | bind_rows(curve_intersect(data.frame(curve[curve$x < max(curve$y),]), data.frame(x = c(0, 10000), y = rep(t[i], 2))))
56 | }
57 |
58 | for(i in 1:length(t)) {
59 | intersections <- intersections %>%
60 | bind_rows(curve_intersect(data.frame(curve[curve$x > max(curve$y),]), data.frame(x = c(0, 10000), y = rep(t[i], 2))))
61 | }
62 | # print(intersections)
63 | }
64 |
65 | p <- ggplot(mapping = aes(x = x, y = y))
66 |
67 | if(!missing(acol)){
68 |
69 | p <- p + geom_ribbon(data = data.frame(curve),
70 | aes(x = x,
71 | ymax = y), ymin = 0,
72 | alpha = alpha, fill = acol)
73 | }
74 |
75 | p <- p + geom_line(data = data.frame(curve), color = 1, size = 1, linetype = 1)
76 |
77 | if(showmax == TRUE) {
78 | p <- p +
79 | geom_segment(data = data.frame(curve[which.max(curve$y), ]),
80 | aes(x = x, y = 0, xend = x, yend = y), lty = "dotted") +
81 | geom_segment(data = data.frame(curve[which.max(curve$y), ]),
82 | aes(x = 0, y = y, xend = x, yend = y), lty = "dotted") +
83 | geom_point(data = curve[which.max(curve$y), ], size = 3, color = pointcol)
84 | }
85 |
86 |
87 | if(!missing(t)){
88 |
89 | p <- p + geom_segment(data = intersections,
90 | aes(x = x, y = 0, xend = x, yend = y), lty = "dotted") +
91 | geom_segment(data = intersections,
92 | aes(x = 0, y = y, xend = x, yend = y), lty = "dotted") +
93 | geom_point(data = intersections, size = 3)
94 |
95 |
96 | if(generic == FALSE){
97 | p <- p + scale_x_continuous(expand = c(0, 0), limits = c(0, max(unlist(curve$x)) + 1),
98 | breaks = intersections$x, labels = round(intersections$x, 2)) +
99 | scale_y_continuous(expand = c(0, 0), limits = c(0, max(unlist(curve$y)) + 1),
100 | breaks = c(intersections$y, max(curve$y)), labels = round(c(intersections$y, max(curve$y)), 2))
101 | } else {
102 |
103 | labels <- rev(sapply(length(intersections$x):1, function(i) as.expression(bquote(t[.(i)]))))
104 |
105 | p <- p + scale_x_continuous(expand = c(0, 0), limits = c(0, max(unlist(curve$x)) + 1),
106 | breaks = c(intersections$x, curve[which.max(curve$y), ]$x), labels = c(labels, "t*")) +
107 | scale_y_continuous(expand = c(0, 0), limits = c(0, max(unlist(curve$y)) + 1),
108 | breaks = c(unique(intersections$y), curve[which.max(curve$y), ]$y), labels = c(rev(sapply(length(unique(intersections$y)):1, function(i) as.expression(bquote("T"[.(i)])))), "T*") )
109 | }
110 |
111 | } else {
112 |
113 | if(generic == FALSE) {
114 | p <- p + scale_x_continuous(expand = c(0, 0), limits = c(0, max(curve$x) + 1), breaks = round(curve[which.max(curve$y), ]$x, 2), labels = round(curve[which.max(curve$y), ]$x, 2)) +
115 | scale_y_continuous(expand = c(0, 0), limits = c(0, max(curve$y) + 1), breaks = round(max(curve$y), 2), labels = round(max(curve$y), 2))
116 | } else {
117 | p <- p + scale_x_continuous(expand = c(0, 0), limits = c(0, max(curve$x) + 1), breaks = curve[which.max(curve$y), ]$x, labels = "t*") +
118 | scale_y_continuous(expand = c(0, 0), limits = c(0, max(curve$y) + 1), breaks = max(curve$y), labels = "T*")
119 |
120 | }
121 | }
122 |
123 | p <- p + labs(x = xlab, y = ylab, title = main, subtitle = sub) +
124 | # coord_equal() +
125 | theme_classic() +
126 | theme(plot.title = element_text(size = rel(1.3)),
127 | axis.title.y = element_text(margin = margin(t = 0, r = 10, b = 0, l = 0), angle = 0, vjust = 1),
128 | axis.title.x = element_text(margin = margin(t = 0, r = 25, b = 0, l = 0), angle = 0, hjust = 1),
129 | plot.background = element_rect(fill = bg.col),
130 | plot.margin = margin(0.5, 1, 0.5, 0.5, "cm"))
131 |
132 | if(missing(t)){
133 | return(list(p = p, curve = curve))
134 | } else {
135 | return(list(p = p, intersections = intersections, curve = curve))
136 | }
137 |
138 | }
139 |
140 |
--------------------------------------------------------------------------------
/R/neolabsup.R:
--------------------------------------------------------------------------------
1 | #' @title Neoclassical labor supply
2 | #'
3 | #' @description Function to create a charts for neoclassical labor supply curves
4 | #'
5 | #' @param ... Custom curve.
6 | #' @param ncurves Number of curves to be created.
7 | #' @param x Y-axis values where to create intersections with the demand curves.
8 | #' @param curve_names Boolean. If `TRUE`, the function adds default names to each.
9 | #' @param names If `curve_names = TRUE` are custom names for the curves.
10 | #' @param linecol Line color of the curves.
11 | #' @param labels If `x` is specified are the labels for the intersection points.
12 | #' @param generic Boolean. If `TRUE` and `x` is specified, the axis labels shows generic names. If `FALSE`, the axis labels are the actual data of the axis that corresponds to the intersection points.
13 | #' @param geom Possible values are `"text"` to display the labels of the intersection points with text and `"label"` to show them with labels.
14 | #' @param geomcol Color of the labels of the intersection points.
15 | #' @param geomfill If `geom = "label"` is the background color of the label.
16 | #' @param main Main title of the plot.
17 | #' @param sub Subtitle of the plot.
18 | #' @param xlab Name of the X-axis.
19 | #' @param ylab Name of the Y-axis.
20 | #' @param bg.col Background color of the plot.
21 | #' @import ggplot2 dplyr
22 | #'
23 | #'
24 | #'
25 | #'
26 | #'
27 | #' @export
28 | neolabsup <- function(...,
29 | ncurves = 1,
30 | x,
31 | curve_names = TRUE,
32 | names, # Names of the supply curves
33 | linecol,
34 | labels, # Label points
35 | generic = TRUE,
36 | geom = "text",
37 | geomcol = 1,
38 | geomfill = "white",
39 | main = NULL,
40 | sub = NULL,
41 | xlab = NULL,
42 | ylab = NULL,
43 | bg.col = "white") {
44 |
45 | if(!missing(labels)){
46 |
47 | if(length(labels) == 1) {
48 | if(labels == "") {
49 | labels <- rep("", length(x))
50 | }
51 | }
52 |
53 | if(length(labels) != length(x)) {
54 | warning(paste("The number of labels provided must be equal to the intersections, so length(labels) must be:", length(x) * ncurves))
55 | }
56 |
57 | }
58 |
59 | m <- FALSE
60 |
61 | if(missing(...)){
62 | ncurve <- ncurves
63 |
64 | # Example indifference curve
65 | curve <- data.frame(Hmisc::bezier(c(1, 9, 2),
66 | c(1, 5, 9)))
67 |
68 | m <- TRUE
69 |
70 | } else {
71 | curve <- list(...)
72 | ncurve <- length(curve)
73 |
74 | class <- vector("character", ncurve)
75 |
76 | for(i in 1:ncurve) {
77 |
78 | class[i] <- class(curve[[i]])
79 |
80 | }
81 |
82 | if(any(class != "data.frame")) {
83 | stop("You can only pass data frames to the '...' argument")
84 | }
85 |
86 | if(ncurve == 1){
87 | m <- TRUE
88 | }
89 | }
90 |
91 |
92 | if(missing(linecol)){
93 |
94 | if(missing(...)){
95 | linecol <- 1
96 | }
97 |
98 | if(!missing(...) & ncurve == 1){
99 | linecol <- 1
100 | }
101 |
102 | if(!missing(...) & ncurve > 1){
103 | linecol <- rep(1, ncurve)
104 | }
105 | } else {
106 |
107 | if(!missing(...) & length(linecol) == 1){
108 | linecol <- rep(linecol, ncurve)
109 | }
110 | }
111 |
112 | if(!missing(x)){
113 |
114 | if(any(x < 0) | any(x > max(data.frame(curve)$y))) {
115 | warning("There are values on the 'x' argument lower than 0 or greater than the maximun value of the curve")
116 | x <- x[x <= max(data.frame(curve)$y)]
117 | }
118 |
119 | # Calculate the intersections of the curves
120 | intersections <- tibble()
121 |
122 |
123 | for(i in 1:length(x)) {
124 | if(x[i] < max(data.frame(curve[curve$y < max(curve$x),])$y)) {
125 | intersections <- intersections %>%
126 | bind_rows(curve_intersect(data.frame(curve[curve$y < max(curve$x),]), data.frame(x = c(0, 10000), y = rep(x[i], 2))))
127 | } else {
128 | intersections <- intersections %>%
129 | bind_rows(curve_intersect(data.frame(curve[curve$y > max(curve$x),]), data.frame(x = c(0, 10000), y = rep(x[i], 2))))
130 |
131 | }
132 | }
133 |
134 |
135 |
136 | }
137 |
138 | if(missing(labels) & !missing(x)){
139 | labels <- LETTERS[1:nrow(intersections)]
140 | }
141 |
142 | p <- ggplot(mapping = aes(x = x, y = y))
143 |
144 |
145 | if(missing(...) | m){
146 |
147 | for(i in 0:(ncurves - 1)) {
148 | p <- p + geom_path(data = data.frame(x = curve$x + i, y = curve$y), color = linecol, size = 1, linetype = 1)
149 | }
150 |
151 | } else {
152 |
153 | for(i in 1:length(curve)) {
154 | p <- p + geom_path(data = data.frame(curve[[i]]), color = linecol[i], size = 1, linetype = 1)
155 | }
156 | }
157 |
158 | if(curve_names == TRUE) {
159 |
160 | if(ncurves == 1) {
161 |
162 | if(missing(names)) {
163 | names <- "S"
164 | }
165 |
166 | p <- p + annotate(geom = "text", x = curve[nrow(curve),]$x - 0.2, y = max(as.data.frame(curve)$y), label = names, parse = TRUE,
167 | size = 4, color = geomcol)
168 | } else {
169 |
170 | if(missing(names)) {
171 | names <- sapply(1:ncurves, function(i) paste0("S[", i, "]"))
172 | }
173 |
174 | j <- 0
175 | for(i in 1:ncurves){
176 | p <- p + annotate(geom = "text", x = curve[nrow(curve),]$x + j - 0.2, y = max(as.data.frame(curve)$y), label = names[i], parse = TRUE,
177 | size = 4, color = geomcol)
178 | j <- j + 1
179 | }
180 | }
181 |
182 | }
183 |
184 | if(!missing(x)) {
185 | p <- p + geom_segment(data = intersections,
186 | aes(x = x, y = 0, xend = x, yend = y), lty = "dotted") +
187 |
188 | geom_segment(data = intersections,
189 | aes(x = 0, y = y, xend = x, yend = y), lty = "dotted") +
190 | geom_point(data = intersections, size = 3)
191 |
192 |
193 | if(geom == "label") {
194 | for(i in 1:nrow(intersections)){
195 |
196 | p <- p + annotate(geom = "label", x = unlist(intersections[1][i, ]) + 0.35, y = unlist(intersections[2][i, ]), label = labels[i],
197 | size = 4, fill = geomfill, color = geomcol)
198 | }
199 | }
200 |
201 | if(geom == "text") {
202 |
203 | for(i in 1:nrow(intersections)){
204 |
205 | p <- p + annotate(geom = "text", x = unlist(intersections[1][i, ]) + 0.35, y = unlist(intersections[2][i, ]), label = labels[i],
206 | size = 4, color = geomcol)
207 | }
208 | }
209 |
210 | if(generic == FALSE) {
211 |
212 | p <- p + scale_x_continuous(expand = c(0, 0), limits = c(0, max(unlist(curve$x)) + ncurves),
213 | breaks = intersections$x, labels = round(intersections$x, 2)) +
214 | scale_y_continuous(expand = c(0, 0), limits = c(0, max(unlist(curve)) + 1),
215 | breaks = unique(round(intersections$y, 2)), labels = unique(round(intersections$y, 2)))
216 |
217 | } else {
218 |
219 | if(ncurve == 1 & missing(...)){
220 |
221 | p <- p + scale_x_continuous(expand = c(0, 0), limits = c(0, max(unlist(curve$x)) + ncurves),
222 | breaks = intersections$x, labels = sapply(1:length(x), function(i) as.expression(bquote(L[.(LETTERS[i])])))) +
223 | scale_y_continuous(expand = c(0, 0), limits = c(0, max(unlist(curve)) + ncurves),
224 | breaks = round(intersections$y, 2), labels = sapply(1:length(x), function(i) as.expression(bquote(W[.(LETTERS[i])]))))
225 | } else {
226 |
227 | labels <- rev(sapply(length(intersections$x):1, function(i) as.expression(bquote(P[.(LETTERS[i])]))))
228 |
229 |
230 | p <- p + scale_x_continuous(expand = c(0, 0), limits = c(0, max(unlist(curve$x)) + ncurves),
231 | breaks = intersections$x, labels = labels) +
232 | scale_y_continuous(expand = c(0, 0), limits = c(0, max(unlist(curve)) + ncurves),
233 | breaks = x, labels = sapply(length(x):1, function(i) as.expression(bquote(Q[.(LETTERS[i])]))))
234 | }
235 |
236 | }
237 | } else {
238 | p <- p + scale_x_continuous(expand = c(0, 0), limits = c(0, max(unlist(curve$x)) + ncurves)) +
239 | scale_y_continuous(expand = c(0, 0), limits = c(0, max(unlist(curve)) + ncurves))
240 | }
241 |
242 | p <- p + labs(x = xlab, y = ylab, title = main, subtitle = sub)
243 |
244 | p <- p +
245 | # coord_equal() +
246 | theme_classic() +
247 | theme(plot.title = element_text(size = rel(1.3)),
248 | # axis.text.x = element_text(colour = linecol),
249 | axis.title.y = element_text(margin = margin(t = 0, r = 10, b = 0, l = 0), angle = 0, vjust = 1),
250 | axis.title.x = element_text(margin = margin(t = 0, r = 25, b = 0, l = 0), angle = 0, hjust = 1),
251 | plot.background = element_rect(fill = bg.col),
252 | plot.margin = margin(0.5, 1, 0.5, 0.5, "cm"))
253 |
254 | if(!missing(x)){
255 | return(list(p = p, intersections = intersections, curve = curve))
256 | } else {
257 | return(list(p = p, curve = curve))
258 | }
259 | }
260 |
261 |
262 |
--------------------------------------------------------------------------------
/R/ppf.R:
--------------------------------------------------------------------------------
1 | #' @title Production–possibility frontier
2 | #'
3 | #' @description Creates production–possibility frontiers. The function allows specifying custom frontiers, modifying the type of the curves (concave or linear), creating intersections along the values of the Y-axis and the curve and customizing the final output with further arguments.
4 | #'
5 | #' @param ... Specify the production–possibility frontiers separated by comma (as `data.frame`) you want to display in the graph. This will override the sample curve.
6 | #' @param xmax Numeric. Allows modifying the maximum X value for the default production–possibility frontier.
7 | #' @param ymax Numeric. Allows modifying the maximum Y value for the default production–possibility frontier.
8 | #' @param type Possible values are `"concave"` (default) and `"line"` to plot a concave or a linear production–possibility frontier function by default, respectively.
9 | #' @param x Y-axis values where to create intersections with the production–possibility frontier
10 | #' @param linecol Line color of the curves.
11 | #' @param labels If `x` is specified are the labels for the intersection points.
12 | #' @param generic Boolean. If `TRUE` and `x` is specified, the axis labels shows generic names. If `FALSE`, the axis labels are the actual data of the axis that corresponds to the intersection points.
13 | #' @param geom Possible values are `"text"` to display the labels of the intersection points with text and `"label"` to show them with labels.
14 | #' @param geomcol Color of the labels of the intersection points.
15 | #' @param geomfill If `geom = "label"` is the background color of the label.
16 | #' @param main Main title of the plot.
17 | #' @param sub Subtitle of the plot.
18 | #' @param xlab Name of the X-axis.
19 | #' @param ylab Name of the Y-axis.
20 | #' @param acol Color of the area of the below the production–possibility frontier
21 | #' @param alpha Transparency of the colored area
22 | #' @param bg.col Background color of the plot
23 | #' @import ggplot2 dplyr
24 | #' @export
25 | ppf <- function(...,
26 | xmax,
27 | ymax,
28 | type = "concave",
29 | x,
30 | linecol,
31 | labels,
32 | generic = TRUE,
33 | geom = "text",
34 | geomcol = 1,
35 | geomfill = "white",
36 | main = NULL,
37 | sub = NULL,
38 | xlab = NULL,
39 | ylab = NULL,
40 | acol,
41 | alpha = 0.3,
42 | bg.col = "white"){
43 |
44 | m <- FALSE
45 |
46 | if(missing(...)){
47 |
48 | ncurve <- 1
49 |
50 | if(missing(xmax)){
51 | xmax <- 6.5
52 | }
53 |
54 | if(missing(ymax)){
55 | ymax <- 6.5
56 | }
57 |
58 | if(type == "concave") {
59 | # Example indifference curve
60 | curve <- data.frame(Hmisc::bezier(c(0, xmax - 1.5, xmax),
61 | c(ymax, ymax - 1.5, 0)))
62 | m <- TRUE
63 | }
64 |
65 | if(type == "line") {
66 | curve <- data.frame(x = c(0, xmax),
67 | y = c(ymax, 0))
68 | m <- TRUE
69 | }
70 | } else{
71 |
72 | curve <- list(...)
73 | ncurve <- length(curve)
74 |
75 | class <- vector("character", ncurve)
76 |
77 | for(i in 1:ncurve) {
78 |
79 | class[i] <- class(curve[[i]])
80 |
81 | }
82 |
83 | if(any(class != "data.frame")) {
84 | stop("You can only pass data frames to the '...' argument")
85 | }
86 |
87 |
88 | if(ncurve == 1){
89 | m <- TRUE
90 | }
91 | }
92 |
93 | if(missing(linecol)){
94 |
95 | if(missing(...)){
96 | linecol <- 1
97 | }
98 |
99 | if(!missing(...) & ncurve == 1){
100 | linecol <- 1
101 | }
102 |
103 | if(!missing(...) & ncurve > 1){
104 | linecol <- rep(1, ncurve)
105 | }
106 | } else {
107 |
108 | if(!missing(...) & length(linecol) == 1){
109 | linecol <- rep(linecol, ncurve)
110 | }
111 | }
112 |
113 | if(missing(labels) & !missing(x)){
114 | labels <- LETTERS[1:length(x)]
115 | }
116 |
117 | if(!missing(x)){
118 |
119 | if(any(x < 0) | any(x > max(data.frame(curve)$y))) {
120 | warning("There are values on the 'x' argument lower than 0 or greater than the maximun value of the curve")
121 | x <- x[x <= max(data.frame(curve)$y)]
122 | }
123 |
124 | # Calculate the intersections of the curves
125 | intersections <- tibble()
126 |
127 | if(missing(...) | length(curve) == 1) {
128 |
129 | for(i in 1:length(x)) {
130 | intersections <- intersections %>%
131 | bind_rows(curve_intersect(data.frame(x = c(0, 10000), y = rep(x[i], 2)), data.frame(curve)))
132 |
133 | }
134 | }else {
135 |
136 | intersections <- vector("list", ncurve)
137 | for(i in 1:ncurve){
138 |
139 | for(j in 1:length(x)) {
140 |
141 | intersections[[i]][[j]] <- bind_rows(curve_intersect(data.frame(x = 1:1000, y = rep(x[j], nrow(curve[[1]]))), curve[[i]]))
142 | }
143 | }
144 |
145 | intersections <- bind_rows(intersections)
146 | }
147 |
148 | print(intersections)
149 | }
150 |
151 | p <- ggplot(mapping = aes(x = x, y = y))
152 |
153 |
154 | if(!missing(acol)){
155 |
156 | p <- p + geom_ribbon(data = data.frame(curve),
157 | aes(x = x,
158 | ymax = y), ymin = 0,
159 | alpha = alpha, fill = acol)
160 | }
161 |
162 | if(missing(...) | m){
163 | p <- p + geom_line(data = data.frame(curve), color = linecol, size = 1, linetype = 1)
164 | } else {
165 |
166 | for(i in 1:length(curve)) {
167 | p <- p + geom_line(data = data.frame(curve[[i]]), color = linecol[i], size = 1, linetype = 1)
168 | }
169 | }
170 |
171 | if(!missing(x)){
172 | p <- p + geom_segment(data = intersections,
173 | aes(x = x, y = 0, xend = x, yend = y), lty = "dotted") +
174 |
175 | geom_segment(data = intersections,
176 | aes(x = 0, y = y, xend = x, yend = y), lty = "dotted") +
177 | geom_point(data = intersections, size = 3)
178 |
179 |
180 | if(geom == "label") {
181 | for(i in 1:length(x)){
182 |
183 | p <- p + annotate(geom = "label", x = unlist(intersections[1][i, ]) + 0.25, y = unlist(intersections[2][i, ]) + 0.25, label = rev(labels)[i],
184 | size = 4, fill = "white", color = geomcol)
185 | }
186 | }
187 |
188 | if(geom == "text") {
189 | for(i in 1:length(x)){
190 |
191 | p <- p + annotate(geom = "text", x = unlist(intersections[1][i, ]) + 0.25, y = unlist(intersections[2][i, ]) + 0.25, label = rev(labels)[i],
192 | size = 4, color = geomcol)
193 | }
194 | }
195 |
196 | if(generic == FALSE) {
197 | p <- p + scale_x_continuous(expand = c(0, 0), limits = c(0, max(unlist(curve)) + 1), breaks = intersections$x, labels = round(intersections$x, 2)) +
198 | scale_y_continuous(expand = c(0, 0), limits = c(0, max(unlist(curve)) + 1), breaks = intersections$y, labels = round(intersections$y, 2))
199 | } else {
200 |
201 | if(ncurve == 1 | missing(...)){
202 |
203 | p <- p + scale_x_continuous(expand = c(0, 0), limits = c(0, max(unlist(curve)) + 1),
204 | breaks = intersections$x, labels = sapply(length(x):1, function(i) as.expression(bquote(X[.(LETTERS[i])])))) +
205 | scale_y_continuous(expand = c(0, 0), limits = c(0, max(unlist(curve)) + 1),
206 | breaks = intersections$y, labels = sapply(length(x):1, function(i) as.expression(bquote(Y[.(LETTERS[i])]))))
207 | } else {
208 |
209 | labels <- sapply(length(intersections$x):1, function(i) as.expression(bquote(X[.(LETTERS[i])])))
210 |
211 | p <- p + scale_x_continuous(expand = c(0, 0), limits = c(0, max(unlist(curve)) + 1),
212 | breaks = intersections$x, labels = labels) +
213 | scale_y_continuous(expand = c(0, 0), limits = c(0, max(unlist(curve)) + 1),
214 | breaks = x, labels =sapply(length(x):1, function(i) as.expression(bquote(Y[.(LETTERS[i])]))))
215 | }
216 |
217 | }
218 | } else {
219 | p <- p + scale_x_continuous(expand = c(0, 0), limits = c(0, max(unlist(curve)) + 1)) +
220 | scale_y_continuous(expand = c(0, 0), limits = c(0, max(unlist(curve)) + 1))
221 | }
222 |
223 | p <- p + labs(x = xlab, y = ylab, title = main, subtitle = sub)
224 |
225 | p <- p +
226 | # coord_equal() +
227 | theme_classic() +
228 | theme(plot.title = element_text(size = rel(1.3)),
229 | # axis.text.x = element_text(colour = linecol),
230 | axis.title.y = element_text(margin = margin(t = 0, r = 10, b = 0, l = 0), angle = 0, vjust = 1),
231 | axis.title.x = element_text(margin = margin(t = 0, r = 25, b = 0, l = 0), angle = 0, hjust = 1),
232 | plot.background = element_rect(fill = bg.col),
233 | plot.margin = margin(0.5, 1, 0.5, 0.5, "cm"))
234 |
235 | if(!missing(x)){
236 | return(list(p = p, intersections = intersections, curve = curve))
237 | } else {
238 | return(list(p = p, curve = curve))
239 | }
240 | }
241 |
--------------------------------------------------------------------------------
/R/ptvalue.R:
--------------------------------------------------------------------------------
1 |
2 | #' @title Value function in Prospect Theory
3 | #'
4 | #' @description Produces asymmetric S-shaped value function according to lessons
5 | #' from Prospect Theory that losses are felt more intensely than gains.
6 | #'
7 | #' @param x Numeric. Vector of gain / loss values for x.
8 | #' @param sigma Number. Exponent of functions, should be less than 1 to make an
9 | #' 'S' shaped curve.
10 | #' @param lambda Number. Extent of asymmetry between losses and gains. Should be
11 | #' less than -1 for losses to be more 'intense' than gains (as suggested by
12 | #' Prospect Theory). Between -1 and 0 for gains to be more intense than
13 | #' losses. Greater than 0 for losses to have positive value.
14 | #' @param xint Numeric. Symmetric intersections. X-intercept values where to
15 | #' highlight points -- will be placed at both `xint` and `abs(xint)` to
16 | #' demonstrate asymmetry in `value`.
17 | #' @param xintcol Color of dashed lines calling-out `xint`.
18 | #' @param main Main title of the plot.
19 | #' @param sub Subtitle of the plot.
20 | #' @param xlab Name of the X-axis.
21 | #' @param ylab Name of the Y-axis.
22 | #' @param col Color of function segment.
23 | #' @param bg.col Background color.
24 | #' @param ticks TOOD
25 | #' @param xlabels TRUE / FALSE : whether x labels are included.
26 | #' @param ylabels TRUE / FALSE : whether y labels are included.
27 | #' @param by_x Number. Increment of the x-axis labels.
28 | #' @param by_y Number. Increment of the x-axis labels.
29 | #'
30 | #' @details TODO
31 | #'
32 | #' @importFrom stats approxfun
33 | #' @references Tversky, Amos; Kahneman, Daniel (1992). "Advances in prospect
34 | #' theory: Cumulative representation of uncertainty". Journal of Risk and
35 | #' Uncertainty. 5 (4): 297–323.
36 | #' @examples
37 | #'
38 | #' ptvalue(
39 | #' sigma = 0.25,
40 | #' xint = 20,
41 | #' xintcol = 'blue',
42 | #' main = "Prospect Theory Shows That Gains & Losses are Felt Assymetrically",
43 | #' sub = "Losses are More Intense"
44 | #' )
45 | #'
46 | #' @export
47 | ptvalue <- function(x, sigma = 0.30, lambda = -2.25, xint, xintcol = 1,
48 | main = NULL, sub = NULL, xlab = "Loss / Gain", ylab = "Value",
49 | col = 1, bg.col = "white", ticks = TRUE,
50 | xlabels = TRUE, ylabels = TRUE, by_x = 10, by_y = 20){
51 |
52 | if(sigma >= 1) warning("sigma should be less than 1 to produce an 'S' shaped curve.")
53 | if(lambda >= -1) warning("lambda should be less than -1 in order that losses be represented as more intense than gains.")
54 |
55 | if(missing(x)) {
56 |
57 | x_pos <- seq(from = log(1), to = log(101), length.out = 1000) %>%
58 | exp() %>%
59 | {. - 1}
60 |
61 | x <- c(sort(-x_pos), 0, x_pos)
62 |
63 | }
64 |
65 | # Tversky & Kahneman, 1992
66 | value <- function(x, sigmaf = sigma, lambdaf = lambda) {
67 |
68 | if (x >= 0) {
69 | return(x ^ sigmaf)
70 | }
71 |
72 | if (x < 0) {
73 | return(lambdaf * (-x) ^ sigmaf)
74 | }
75 | }
76 |
77 | value <- Vectorize(value, vectorize.args = "x")
78 |
79 | maxv <- max(abs(value(x)))
80 | p <- ggplot(data = tibble(x = x), mapping = aes(x))
81 |
82 |
83 | if(ticks == TRUE) {
84 | # Axis ticks
85 |
86 |
87 | ## X-axis
88 |
89 | x_axis_max <- max(x)
90 | x_axis_min <- -x_axis_max
91 |
92 | tick_frame_x <- data.frame(ticks = seq(x_axis_min, x_axis_max, by = by_x), zero = 0) %>%
93 | subset(ticks != 0)
94 |
95 |
96 | ## Y-axis
97 |
98 | y_axis_max <- max(abs(value(x, sigma, lambda)))
99 | y_axis_min <- -y_axis_max
100 |
101 | tick_frame_y <- data.frame(ticks = seq(y_axis_min, y_axis_max, by = by_y), zero = 0) %>%
102 | subset(ticks != 0)
103 |
104 |
105 |
106 | tick_sz_y <- 0.02 * x_axis_max
107 | tick_sz_x <- 0.02 * y_axis_max
108 |
109 | p <- p + geom_segment(data = tick_frame_x,
110 | aes(x = ticks, xend = ticks,
111 | y = zero, yend = zero + tick_sz_x)) +
112 | geom_segment(data = tick_frame_y,
113 | aes(x = zero, xend = zero + tick_sz_y,
114 | y = ticks, yend = ticks))
115 |
116 | }
117 |
118 |
119 | # Labels
120 |
121 | if(xlabels == TRUE) {
122 | p <- p + geom_text(data = tick_frame_x, aes(x = ticks, y = zero, label = round(ticks, 2)), vjust = 1.5)
123 | }
124 |
125 | if(ylabels == TRUE) {
126 | p <- p + geom_text(data = tick_frame_y, aes(x = zero, y = ticks, label = round(ticks, 2)), hjust = 1.25)
127 | }
128 |
129 | p <- p + geom_line(aes(x = x, y = value(x)), col = col)
130 |
131 | if(!missing(xint)) {
132 |
133 | curve <- data.frame(x = x, y = value(x))
134 |
135 | aprox <- approxfun(curve$x, curve$y)
136 |
137 | a <- aprox(xint)
138 | b <- aprox(-xint)
139 | len <- length(xint)
140 |
141 | data <- data.frame(xint = xint, y = rep(0, len), a = a, b = b)
142 |
143 | p <- p + geom_segment(data = data, aes(x = xint, y = y, xend = xint, yend = a), lty = "dashed", colour = xintcol) +
144 | geom_segment(data = data, aes(x = xint, y = a, xend = y, yend = a), lty = "dashed", colour = xintcol) +
145 | geom_point(data = data, aes(x = xint, y = a), size = 3) +
146 |
147 | geom_segment(data = data, aes(x = -xint, y = y, xend = -xint, yend = b), lty = "dashed", colour = xintcol) +
148 | geom_segment(data = data, aes(x = -xint, y = b, xend = y, yend = b), lty = "dashed", colour = xintcol) +
149 | geom_point(data = data, aes(x = -xint, y = b), size = 3)
150 |
151 | }
152 |
153 | p <- p + labs(x = ylab, y = xlab, title = main, subtitle = sub) +
154 | geom_hline(yintercept = 0) +
155 | geom_vline(xintercept = 0) +
156 | scale_y_continuous(limits = c(-maxv, maxv)) +
157 | theme_void() +
158 | theme(plot.title = element_text(size = rel(1.3)),
159 | axis.title.y = element_text(margin = margin(t = 0, r = 10, b = 0, l = 0), angle = 0, vjust = 0.5),
160 | axis.title.x = element_text(margin = margin(t = 0, r = 25, b = 0, l = 0), angle = 0, hjust = 0.5),
161 | plot.background = element_rect(fill = bg.col),
162 | plot.margin = margin(0.5, 1, 0.5, 0.5, "cm"))
163 |
164 | return(p)
165 |
166 | }
167 |
168 |
169 |
170 | # ptvalue(col = 2, xint = seq(0, 100, 25), xintcol = 4,
171 | # by_x = 25, by_y = 50,
172 | # main = "Prospect Theory Value Function")
173 |
174 |
--------------------------------------------------------------------------------
/R/sdcurve.R:
--------------------------------------------------------------------------------
1 | #' @title Supply and demand curves
2 | #'
3 | #' @description Create supply and demand curves. By default, the function will use a default supply and a default demand curve, but this can be overridden passing new curves as additional arguments or modifying the `xmax` and `ymax` arguments.
4 | #' Moreover, the function provides several arguments to customize the final output, like displaying the equilibrium points, the name of the curves, customizing the title, subtitle or axis labels, among others.
5 | #'
6 | #' @param ... Specify the demand and supply curve or curves separated by commas (as `data.frame`) you want to display in the graph, starting with supply. This will override the sample curves.
7 | #' @param xmax Numeric. Allows modifying the maximum X value for the default functions.
8 | #' @param ymax Numeric. Allows modifying the maximum Y value for the default functions.
9 | #' @param max.price Price ceiling.
10 | #' @param min.price Price floor.
11 | #' @param generic Boolean. If `TRUE`, the axis labels shows generic names. If `FALSE`, the axis labels are the actual data of the axis that corresponds to the intersection points between the two curves.
12 | #' @param equilibrium Boolean. If `TRUE`, shows the intersection points between the two curves.
13 | #' @param main Main title of the plot.
14 | #' @param sub Subtitle of the plot.
15 | #' @param xlab Name of the X-axis.
16 | #' @param ylab Name of the Y-axis.
17 | #' @param curve_names Boolean. If `TRUE`, the function adds default names to each.
18 | #' @param names If `curve_names = TRUE`, are custom names for the curves.
19 | #' @param linescol Color of the curves. It must be a vector of the same length as the number of displayed curves.
20 | #' @param bg.col Background color of the plot.
21 | #'
22 | #'
23 | #' @examples
24 | #' sdcurve() # Default supply and demand plot
25 | # Custom data
26 | #' supply1 <- data.frame(x = c(1, 9), y = c(1, 9))
27 | #' supply1
28 | #'
29 | #' demand1 <- data.frame(x = c(7, 2), y = c(2, 7))
30 | #' demand1
31 | #'
32 | #' supply2 <- data.frame(x = c(2, 10), y = c(1, 9))
33 | #' supply2
34 | #'
35 | #' demand2 <- data.frame(x = c(8, 2), y = c(2, 8))
36 | #' demand2
37 | #'
38 | #' p <- sdcurve(supply1, # Custom data
39 | #' demand1,
40 | #' supply2,
41 | #' demand2,
42 | #' equilibrium = TRUE, # Calculate the equilibrium
43 | #' bg.col = "#fff3cd") # Background color
44 | #' p + annotate("segment", x = 2.5, xend = 3, y = 6.5, yend = 7, # Add more layers
45 | #' arrow = arrow(length = unit(0.3, "lines")), colour = "grey50")
46 | #'
47 | #'
48 | #' @import ggplot2 dplyr
49 | #' @export
50 | sdcurve <- function(...,
51 | xmax,
52 | ymax,
53 | max.price,
54 | min.price,
55 | generic = TRUE,
56 | equilibrium = TRUE,
57 | main = NULL,
58 | sub = NULL,
59 | xlab = NULL,
60 | ylab = NULL,
61 | curve_names = TRUE,
62 | names,
63 | linescol,
64 | bg.col = "white") {
65 |
66 | # if(empirical == FALSE && missing(domain)){
67 | # stop("Provide a domain for the empirical curves")
68 | # }
69 |
70 | if(missing(xmax)) {
71 | xmax <- 9
72 | }
73 |
74 | if(missing(ymax)) {
75 | ymax <- 9
76 | }
77 |
78 | if(missing(...)) {
79 | curves <-list(data.frame(Hmisc::bezier(c(1, 8, xmax),
80 | c(1, 5, xmax))), data.frame(Hmisc::bezier(c(1, 3, xmax),
81 | c(ymax, 3, 1))))
82 | ncurves <- 1
83 |
84 | } else {
85 | ncurves <- length(list(...))/2
86 | curves <- list(...)
87 |
88 | class <- vector("character", length(curves))
89 |
90 | for(i in 1:length(curves)) {
91 |
92 | class[i] <- class(curves[[i]])
93 |
94 | }
95 |
96 | if(any(class != "data.frame")) {
97 | stop("You can only pass data frames to the '...' argument")
98 | }
99 |
100 | }
101 |
102 | if(ncurves %% 2 == 0){
103 | par <- TRUE
104 | }
105 |
106 | if(missing(linescol)){
107 | linescol <- 1:length(curves)
108 | }
109 |
110 | # print(ncurves)
111 | # print(curves)
112 |
113 | if(equilibrium == TRUE) {
114 |
115 | # Calculate the intersections of the curves
116 | intersections <- tibble()
117 | j <- 2
118 |
119 | for(i in 1:ncurves) {
120 | intersections <- intersections %>%
121 | bind_rows(curve_intersect(data.frame(curves[j - 1]), data.frame(curves[j])))
122 | j <- j + 2
123 | }
124 |
125 | print(intersections)
126 | }
127 |
128 | # Max X Coordinates of the curves
129 | coord <- vector("list", length = length(curves))
130 | for(i in 1:length(curves)){
131 |
132 | coord[[i]] <- curves[[i]][which.max(curves[[i]][, 1]), ]
133 | }
134 |
135 | p <- ggplot(mapping = aes(x = x, y = y))
136 |
137 | for(i in 1:length(curves)) {
138 | p <- p + geom_line(data = data.frame(curves[i]), color = linescol[i], size = 1, linetype = 1)
139 |
140 | }
141 |
142 | if(equilibrium == TRUE) {
143 | p <- p + geom_segment(data = intersections,
144 | aes(x = x, y = 0, xend = x, yend = y), lty = "dotted") +
145 | geom_segment(data = intersections,
146 | aes(x = 0, y = y, xend = x, yend = y), lty = "dotted") +
147 | geom_point(data = intersections, size = 3)
148 | }
149 |
150 |
151 | if(!missing(max.price) & !missing(min.price)) {
152 | if(min.price >= max.price) {
153 | stop("'max.price' must be greater than 'min.price'")
154 | }
155 | }
156 |
157 | if(!missing(max.price)){
158 |
159 |
160 | # Calculate the intersections of the curves and the line
161 | # intersections <- tibble()
162 | # j <- 2
163 | #
164 | # for(i in 1:ncurves) {
165 | # intersections_max <- intersections %>%
166 | # bind_rows(curve_intersect(data.frame(curves[j - 1]), data.frame(curves[j])))
167 | # j <- j + 2
168 | # }
169 | #
170 | # print(intersections_max)
171 |
172 | p <- p + geom_segment(data = data.frame(x = seq(min(unlist(curves)), max(unlist(curves)), length.out = 2), y = rep(max.price, 2)),
173 | aes(x = 0, y = y, xend = x, yend = y), lty = "dotted")
174 | }
175 |
176 |
177 | if(!missing(min.price)){
178 |
179 |
180 | # Calculate the intersections of the curves and the line
181 | # intersections <- tibble()
182 | # j <- 2
183 | #
184 | # for(i in 1:ncurves) {
185 | # intersections_max <- intersections %>%
186 | # bind_rows(curve_intersect(data.frame(curves[j - 1]), data.frame(curves[j])))
187 | # j <- j + 2
188 | # }
189 | #
190 | # print(intersections_max)
191 |
192 | p <- p + geom_segment(data = data.frame(x = seq(min(unlist(curves)), max(unlist(curves)), length.out = 2), y = rep(min.price, 2)),
193 | aes(x = 0, y = y, xend = x, yend = y), lty = "dotted")
194 | }
195 |
196 |
197 |
198 | # Curve labels
199 |
200 | if(curve_names == TRUE) {
201 |
202 | labelyfun <- numeric(length(curves))
203 |
204 | for(i in 1:length(curves)){
205 |
206 | labelyfun[i] <- approxfun(curves[[i]]$x, curves[[i]]$y)(max(coord[[i]] - 0.5))
207 | }
208 |
209 | if(!missing(names)) {
210 |
211 | for(i in 1:length(curves)){
212 |
213 | p <- p + annotate(geom = "label", x = max(coord[[i]] - 0.5), y = labelyfun[i], label = names[i], parse = TRUE,
214 | size = 4, fill = i, color = "white")
215 | }
216 |
217 | } else {
218 |
219 | for(i in 1:length(curves)){
220 |
221 | l <- ifelse(i %% 2 == 0, "D", "S")
222 |
223 | p <- p + annotate(geom = "label", x = max(coord[[i]] - 0.5), y = labelyfun[i], label = l, parse = TRUE,
224 | size = 4, fill = i, color = "white")
225 | }
226 |
227 | }
228 |
229 | }
230 |
231 | if(equilibrium == TRUE) {
232 |
233 | if(generic == TRUE){
234 |
235 | p <- p + scale_x_continuous(expand = c(0, 0), breaks = unique(intersections$x),limits = c(0, max(unlist(curves)) + 1),
236 | labels = sapply(1:length(unique(intersections$x)), function(i) as.expression(bquote(Q[.(i)])))) +
237 | scale_y_continuous(expand = c(0, 0), breaks = unique(round(intersections$y, 2)), limits = c(0, max(unlist(curves)) + 1),
238 | labels = sapply(1:length(unique(round(intersections$y, 2))), function(i) as.expression(bquote(P[.(i)]))))
239 |
240 | } else {
241 |
242 | p <- p + scale_x_continuous(expand = c(0, 0), breaks = unique(intersections$x), limits = c(0, max(unlist(curves)) + 1),
243 | labels = round(unique(intersections$x), 2)) +
244 | scale_y_continuous(expand = c(0, 0), breaks = unique(intersections$y), limits = c(0, max(unlist(curves)) + 1),
245 | labels = round(unique(intersections$y, 2)))
246 | }
247 |
248 | } else {
249 |
250 | p <- p + scale_x_continuous(expand = c(0, 0), limits = c(0, max(unlist(curves)) + 1)) +
251 | scale_y_continuous(expand = c(0, 0), limits = c(0, max(unlist(curves)) + 1))
252 |
253 | }
254 |
255 | p <- p + labs(x = xlab, y = ylab, title = main, subtitle = sub) +
256 | # coord_equal() +
257 | theme_classic() +
258 | theme(plot.title = element_text(size = rel(1.3)),
259 | axis.title.y = element_text(margin = margin(t = 0, r = 10, b = 0, l = 0), angle = 0, vjust = 1),
260 | axis.title.x = element_text(margin = margin(t = 0, r = 25, b = 0, l = 0), angle = 0, hjust = 1),
261 | plot.background = element_rect(fill = bg.col),
262 | plot.margin = margin(0.5, 1, 0.5, 0.5, "cm"))
263 |
264 | return(p)
265 | }
266 |
267 |
268 |
269 |
270 |
271 |
--------------------------------------------------------------------------------
/R/supply.R:
--------------------------------------------------------------------------------
1 | #' @title Supply curves
2 | #'
3 | #' @description Create supply curves. The function allows specifying the number of curves to generate or use custom curves, the type of curve (convex or linear), create intersection points along the Y-axis and customize other arguments related to the style of the final output.
4 | #'
5 | #' @param ... Specify the supply curve or curves separated by comma (as `data.frame`) you want to display in the graph. This will override the sample curve.
6 | #' @param ncurves Number of supply curves to be generated based on the sample data.
7 | #' @param xmax Numeric. Allows modifying the maximum X value for the default supply function.
8 | #' @param ymax Numeric. Allows modifying the maximum Y value for the default supply function.
9 | #' @param type Possible values are `"convex"` (default) and `"line"` to plot a convex or a linear supply function by default, respectively.
10 | #' @param x Y-axis values where to create intersections with the demand curves.
11 | #' @param curve_names Boolean. If `TRUE`, the function adds default names to each.
12 | #' @param names If `curve_names = TRUE` are custom names for the curves.
13 | #' @param linecol Line color of the curves.
14 | #' @param labels If `x` is specified are the labels for the intersection points.
15 | #' @param generic Boolean. If `TRUE` and `x` is specified, the axis labels shows generic names. If `FALSE`, the axis labels are the actual data of the axis that corresponds to the intersection points.
16 | #' @param geom Possible values are `"text"` to display the labels of the intersection points with text and `"label"` to show them with labels.
17 | #' @param geomcol Color of the labels of the intersection points.
18 | #' @param geomfill If `geom = "label"` is the background color of the label.
19 | #' @param main Main title of the plot.
20 | #' @param sub Subtitle of the plot.
21 | #' @param xlab Name of the X-axis.
22 | #' @param ylab Name of the Y-axis.
23 | #' @param bg.col Background color of the plot.
24 | #' @import ggplot2 dplyr
25 | #'
26 | #'
27 | #'
28 | #'
29 | #'
30 | #' @export
31 | supply <- function(...,
32 | ncurves = 1,
33 | xmax,
34 | ymax,
35 | type = "convex",
36 | x,
37 | curve_names = TRUE,
38 | names, # Names of the supply curves
39 | linecol,
40 | labels, # Label points
41 | generic = TRUE,
42 | geom = "text",
43 | geomcol = 1,
44 | geomfill = "white",
45 | main = NULL,
46 | sub = NULL,
47 | xlab = NULL,
48 | ylab = NULL,
49 | bg.col = "white") {
50 |
51 | if(!missing(labels)){
52 |
53 | if(length(labels) == 1) {
54 | if(labels == "") {
55 | labels <- rep("", length(x))
56 | }
57 | }
58 |
59 | if(length(labels) != length(x)) {
60 | warning(paste("The number of labels provided must be equal to the intersections, so length(labels) must be:", length(x) * ncurves))
61 | }
62 |
63 | }
64 |
65 | m <- FALSE
66 |
67 | if(missing(...)){
68 | ncurve <- ncurves
69 |
70 | if(missing(xmax)){
71 | xmax <- 9
72 | }
73 |
74 | if(missing(ymax)){
75 | ymax <- 9
76 | }
77 |
78 | if(type == "convex") {
79 | # Example indifference curve
80 | curve <- data.frame(Hmisc::bezier(c(1, 8, xmax),
81 | c(1, 5, ymax)))
82 |
83 | m <- TRUE
84 | }
85 |
86 | if(type == "line") {
87 | curve <- data.frame(x = c(0.9, xmax),
88 | y = c(0.9, ymax))
89 | m <- TRUE
90 | }
91 | } else {
92 | curve <- list(...)
93 | ncurve <- length(curve)
94 |
95 | class <- vector("character", ncurve)
96 |
97 | for(i in 1:ncurve) {
98 |
99 | class[i] <- class(curve[[i]])
100 |
101 | }
102 |
103 | if(any(class != "data.frame")) {
104 | stop("You can only pass data frames to the '...' argument")
105 | }
106 |
107 | if(ncurve == 1){
108 | m <- TRUE
109 | }
110 | }
111 |
112 |
113 | if(missing(linecol)){
114 |
115 | if(missing(...)){
116 | linecol <- 1
117 | }
118 |
119 | if(!missing(...) & ncurve == 1){
120 | linecol <- 1
121 | }
122 |
123 | if(!missing(...) & ncurve > 1){
124 | linecol <- rep(1, ncurve)
125 | }
126 | } else {
127 |
128 | if(!missing(...) & length(linecol) == 1){
129 | linecol <- rep(linecol, ncurve)
130 | }
131 | }
132 |
133 | if(!missing(x)){
134 |
135 | if(any(x < 0) | any(x > max(data.frame(curve)$y))) {
136 | warning("There are values on the 'x' argument lower than 0 or greater than the maximun value of the curve")
137 | x <- x[x <= max(data.frame(curve)$y)]
138 | }
139 |
140 | # Calculate the intersections of the curves
141 | intersections <- tibble()
142 |
143 | if((missing(...) | length(curve) == 1) & ncurves == 1) {
144 |
145 | for(i in 1:length(x)) {
146 | intersections <- intersections %>%
147 | bind_rows(curve_intersect(data.frame(x = c(0, 10000), y = rep(x[i], 2)), data.frame(curve)))
148 |
149 | }
150 | } else {
151 |
152 | intersections <- vector("list", ncurve)
153 |
154 | if(ncurves > 1) {
155 |
156 | if(length(x) == 1) {
157 | w <- 0
158 | for(i in 1:ncurve){
159 |
160 | for(j in 1:length(x)) {
161 |
162 | intersections[[i]][[j]] <- bind_rows(curve_intersect(data.frame(x = 1:1000, y = rep(x[j], nrow(curve))), data.frame(x = curve$x + w, y = curve$y)))
163 | w <- w + 1
164 | }
165 | }
166 |
167 | intersections <- bind_rows(intersections)
168 | } else {
169 | stop("Multiple intersections with ncurves > 1 is not implemented yet")
170 | }
171 |
172 | } else {
173 |
174 | for(i in 1:ncurve){
175 |
176 | for(j in 1:length(x)) {
177 |
178 | intersections[[i]][[j]] <- bind_rows(curve_intersect(data.frame(x = 1:1000, y = rep(x[j], nrow(curve[[1]]))), curve[[i]]))
179 | }
180 | }
181 |
182 | intersections <- bind_rows(intersections)
183 |
184 | }
185 | }
186 | # print(intersections)
187 | }
188 |
189 | if(missing(labels) & !missing(x)){
190 | labels <- LETTERS[1:nrow(intersections)]
191 | }
192 |
193 | p <- ggplot(mapping = aes(x = x, y = y))
194 |
195 |
196 | if(missing(...) | m){
197 |
198 | for(i in 0:(ncurves - 1)) {
199 | p <- p + geom_line(data = data.frame(x = curve$x + i, y = curve$y), color = linecol, size = 1, linetype = 1)
200 | }
201 |
202 | } else {
203 |
204 | for(i in 1:length(curve)) {
205 | p <- p + geom_line(data = data.frame(curve[[i]]), color = linecol[i], size = 1, linetype = 1)
206 | }
207 | }
208 |
209 | if(curve_names == TRUE) {
210 |
211 | if(ncurves == 1) {
212 |
213 | if(missing(names)) {
214 | names <- "S"
215 | }
216 |
217 | p <- p + annotate(geom = "text", x = max(as.data.frame(curve)$x) + 0.5, y = max(as.data.frame(curve)$y), label = names, parse = TRUE,
218 | size = 4, color = geomcol)
219 | } else {
220 |
221 | if(missing(names)) {
222 | names <- sapply(1:ncurves, function(i) paste0("S[", i, "]"))
223 | }
224 |
225 | j <- 0
226 | for(i in 1:ncurves){
227 | p <- p + annotate(geom = "text", x = max(as.data.frame(curve)$x) + j + 0.35, y = max(as.data.frame(curve)$y), label = names[i], parse = TRUE,
228 | size = 4, color = geomcol)
229 | j <- j + 1
230 | }
231 | }
232 |
233 | }
234 |
235 | if(!missing(x)) {
236 | p <- p + geom_segment(data = intersections,
237 | aes(x = x, y = 0, xend = x, yend = y), lty = "dotted") +
238 |
239 | geom_segment(data = intersections,
240 | aes(x = 0, y = y, xend = x, yend = y), lty = "dotted") +
241 | geom_point(data = intersections, size = 3)
242 |
243 |
244 | if(geom == "label") {
245 | for(i in 1:nrow(intersections)){
246 |
247 | p <- p + annotate(geom = "label", x = unlist(intersections[1][i, ]) + 0.35, y = unlist(intersections[2][i, ]), label = labels[i],
248 | size = 4, fill = geomfill, color = geomcol)
249 | }
250 | }
251 |
252 | if(geom == "text") {
253 |
254 | for(i in 1:nrow(intersections)){
255 |
256 | p <- p + annotate(geom = "text", x = unlist(intersections[1][i, ]) + 0.35, y = unlist(intersections[2][i, ]), label = labels[i],
257 | size = 4, color = geomcol)
258 | }
259 | }
260 |
261 | if(generic == FALSE) {
262 |
263 | p <- p + scale_x_continuous(expand = c(0, 0), limits = c(0, max(unlist(curve)) + ncurves),
264 | breaks = intersections$x, labels = round(intersections$x, 2)) +
265 | scale_y_continuous(expand = c(0, 0), limits = c(0, max(unlist(curve)) + 1),
266 | breaks = unique(round(intersections$y, 2)), labels = unique(round(intersections$y, 2)))
267 |
268 | } else {
269 |
270 | if(ncurve == 1 & missing(...)){
271 |
272 | p <- p + scale_x_continuous(expand = c(0, 0), limits = c(0, max(unlist(curve)) + ncurves),
273 | breaks = intersections$x, labels = sapply(1:length(x), function(i) as.expression(bquote(X[.(LETTERS[i])])))) +
274 | scale_y_continuous(expand = c(0, 0), limits = c(0, max(unlist(curve)) + ncurves),
275 | breaks = round(intersections$y, 2), labels = sapply(1:length(x), function(i) as.expression(bquote(Y[.(LETTERS[i])]))))
276 | } else {
277 |
278 | labels <- rev(sapply(length(intersections$x):1, function(i) as.expression(bquote(P[.(LETTERS[i])]))))
279 |
280 |
281 | p <- p + scale_x_continuous(expand = c(0, 0), limits = c(0, max(unlist(curve)) + ncurves),
282 | breaks = intersections$x, labels = labels) +
283 | scale_y_continuous(expand = c(0, 0), limits = c(0, max(unlist(curve)) + ncurves),
284 | breaks = x, labels = sapply(length(x):1, function(i) as.expression(bquote(Q[.(LETTERS[i])]))))
285 | }
286 |
287 | }
288 | } else {
289 | p <- p + scale_x_continuous(expand = c(0, 0), limits = c(0, max(unlist(curve)) + ncurves)) +
290 | scale_y_continuous(expand = c(0, 0), limits = c(0, max(unlist(curve)) + ncurves))
291 | }
292 |
293 | p <- p + labs(x = xlab, y = ylab, title = main, subtitle = sub)
294 |
295 | p <- p +
296 | # coord_equal() +
297 | theme_classic() +
298 | theme(plot.title = element_text(size = rel(1.3)),
299 | # axis.text.x = element_text(colour = linecol),
300 | axis.title.y = element_text(margin = margin(t = 0, r = 10, b = 0, l = 0), angle = 0, vjust = 1),
301 | axis.title.x = element_text(margin = margin(t = 0, r = 25, b = 0, l = 0), angle = 0, hjust = 1),
302 | plot.background = element_rect(fill = bg.col),
303 | plot.margin = margin(0.5, 1, 0.5, 0.5, "cm"))
304 |
305 | if(!missing(x)){
306 | return(list(p = p, intersections = intersections, curve = curve))
307 | } else {
308 | return(list(p = p, curve = curve))
309 | }
310 | }
311 |
--------------------------------------------------------------------------------
/R/tax.R:
--------------------------------------------------------------------------------
1 | #' @title Tax graph
2 | #'
3 | #' @description TODO
4 | #'
5 | #' @param demand_fun TODO
6 | #' @param supply_fun TODO
7 | #' @param supply_tax TODO
8 | #' @param names TODO
9 | #' @param title TODO
10 | #' @param xlab TODO
11 | #' @param ylab TODO
12 | #' @param colors TODO
13 | #' @param shaded TODO
14 | #' @param xlim TODO
15 | #' @param ylim TODO
16 | #' @param max_x TODO
17 | #' @param bg.col TODO
18 | #'
19 | #' @author
20 | #' \itemize{
21 | #' \item{Weiss, Andrew.}
22 | #' }
23 | #'
24 | #' @examples
25 | #'
26 | #' # Data
27 | #' demand <- function(Q) 20 - 0.5 * Q
28 | #' demand_new <- function(Q) demand(Q) + 5
29 | #' supply <- function(Q) 2 + 0.25 * Q
30 | #' supply_new <- function(Q) supply(Q) + 5
31 | #'
32 | #' supply_tax <- function(Q) supply(Q) + 5
33 | #'
34 | #' demand_elastic <- function(Q) 10 - 0.05 * Q
35 | #' demand_inelastic <- function(Q) 20 - 2 * Q
36 | #'
37 | #' supply_elastic <- function(Q) 2 + 0.05 * Q
38 | #' supply_elastic_tax <- function(Q) supply_elastic(Q) + 5
39 | #' supply_inelastic <- function(Q) 2 + 1.5 * Q
40 | #' supply_inelastic_tax <- function(Q) supply_inelastic(Q) + 5
41 | #'
42 | #' normal_taxes <- tax_graph(demand, supply, supply_tax, NULL)
43 | #' normal_taxes_shaded <- tax_graph(demand, supply, supply_tax, shaded = TRUE)
44 | #' normal_taxes_shaded$p
45 | #'
46 | #' @import ggplot2 dplyr
47 | #' @export
48 | tax_graph <- function(demand_fun, supply_fun, supply_tax, names = c("Consumer surplus", "Producer surplus", "DWL", "Consumer tax burden", "Producer tax burden"),
49 | title = NULL, xlab = "Product (Q)",
50 | ylab = "Price (P)", colors, shaded = FALSE, xlim = c(0, 45),
51 | ylim = c(0, 20), max_x = 45, bg.col = "white") {
52 |
53 | if(missing(colors)) {
54 | # Aurora and Frost color palettes from Nord
55 | # https://github.com/arcticicestudio/nord
56 | nord_red <- "#BF616A" # nord11
57 | nord_orange <- "#D08770" # nord12
58 | nord_yellow <- "#EBCB8B" # nord13
59 | nord_green <- "#A3BE8C" # nord14
60 | nord_purple <- "#B48EAD" # nord15
61 | nord_lt_blue <- "#81A1C1" # nord9
62 | nord_dk_blue <- "#5E81AC" # nord10
63 | } else {
64 |
65 | if(length(colors) != 7 ) {
66 |
67 | warning("You must provide 7 colors. Default colors will be used instead")
68 |
69 | nord_red <- "#BF616A" # nord11
70 | nord_orange <- "#D08770" # nord12
71 | nord_yellow <- "#EBCB8B" # nord13
72 | nord_green <- "#A3BE8C" # nord14
73 | nord_purple <- "#B48EAD" # nord15
74 | nord_lt_blue <- "#81A1C1" # nord9
75 | nord_dk_blue <- "#5E81AC" # nord10
76 |
77 | } else {
78 |
79 | nord_red <- colors[1]
80 | nord_orange <- colors[2]
81 | nord_yellow <- colors[3]
82 | nord_green <- colors[4]
83 | nord_purple <- colors[5]
84 | nord_lt_blue <- colors[6]
85 | nord_dk_blue <- colors[7]
86 |
87 | }
88 |
89 | }
90 |
91 | midpoint <- function(ymin, ymax) {
92 | ymax + (ymin - ymax) / 2
93 | }
94 |
95 | print_details <- function(coordinates, areas, areas_intermediate) {
96 | coordinates_r <- lapply(coordinates, round, digits = 2)
97 | areas_r <- lapply(areas, round, digits = 2)
98 | areas_intermediate_r <- lapply(areas_intermediate, round, digits = 2)
99 |
100 | glue::glue("
101 | - Pre-tax quantity: **{coordinates_r$qstar_comp}**
102 | - Pre-tax price: **\\${coordinates_r$pstar_comp}**
103 | - Pre-tax consumer surplus: **\\${areas_r$con_surplus}** ($1/2 \\times {areas_intermediate_r$con_surplus_base} \\times {areas_intermediate_r$con_surplus_height}$)
104 | - Pre-tax producer surplus: **\\${areas_r$pro_surplus}** ($1/2 \\times {areas_intermediate_r$pro_surplus_base} \\times {areas_intermediate_r$pro_surplus_height}$)
105 |
106 | - Post-tax quantity: **{coordinates_r$qstar_tax}**
107 | - Post-tax price: **\\${coordinates_r$pstar_tax}**
108 | - Post-tax consumer surplus: **\\${areas_r$con_surplus_tax}** ($1/2 \\times {areas_intermediate_r$con_surplus_tax_base} \\times {areas_intermediate_r$con_surplus_tax_height}$)
109 | - Post-tax producer surplus: **\\${areas_r$pro_surplus_tax}** ($1/2 \\times {areas_intermediate_r$pro_surplus_tax_base} \\times {areas_intermediate_r$pro_surplus_tax_height}$)
110 |
111 | - Deadweight loss: **\\${areas_r$dwl}** ($1/2 \\times {areas_intermediate_r$dwl_base} \\times {areas_intermediate_r$dwl_height}$)
112 |
113 | - Total tax incidence (revenue raised): **\\${areas_r$total_incidence}** ($({coordinates_r$pstar_tax} - {coordinates_r$psupplied_tax}) \\times {coordinates_r$qstar_tax}$)
114 | - Consumer tax incidence: **\\${areas_r$con_incidence}** ($({coordinates_r$pstar_tax} - {coordinates_r$pstar_comp}) \\times {coordinates_r$qstar_tax}$)
115 | - Producer tax incidence: **\\${areas_r$pro_incidence}** ($({coordinates_r$pstar_comp} - {coordinates_r$psupplied_tax}) \\times {coordinates_r$qstar_tax}$)
116 | - Percent of tax borne by consumers: **{scales::percent(areas$con_incidence_pct)}** (${areas_r$con_incidence} / {areas_r$total_incidence}$)
117 | - Percent of tax borne by producers: **{scales::percent(areas$pro_incidence_pct)}** (${areas_r$pro_incidence} / {areas_r$total_incidence}$)
118 | ")
119 | }
120 |
121 |
122 | pts <- function(x) {
123 | as.numeric(grid::convertUnit(grid::unit(x, "pt"), "mm"))
124 | }
125 |
126 | # update_geom_defaults("text", list(family = "IBM Plex Sans Condensed SemiBold"))
127 | # update_geom_defaults("label", list(family = "IBM Plex Sans Condensed SemiBold"))
128 |
129 | theme_econ <- function(base_size = 11, axis_line = FALSE) {
130 | # update_geom_defaults("label", list(family = "IBM Plex Sans Condensed Light"))
131 | # update_geom_defaults("text", list(family = "IBM Plex Sans Condensed Light"))
132 |
133 | ret <- theme_bw(base_size) +
134 | theme(axis.title.y = element_text(margin = margin(r = 10)),
135 | axis.title.x = element_text(margin = margin(t = 10)),
136 | plot.title = element_text(size = rel(1.4), face = "plain"),
137 | plot.subtitle = element_text(size = rel(1), face = "plain"),
138 | plot.caption = element_text(size = rel(0.8), color = "grey50", face = "plain"),
139 | strip.text = element_text(size = rel(1), face = "plain"),
140 | legend.title = element_text(size = rel(0.8)),
141 | panel.border = element_blank(),
142 | axis.ticks = element_blank(),
143 | strip.background = element_rect(fill = "#ffffff", colour=NA),
144 | panel.spacing.y = unit(1.5, "lines"),
145 | legend.key = element_blank(),
146 | legend.spacing = unit(0.1, "lines"),
147 | legend.box.margin = margin(t = -0.25, unit = "lines"),
148 | legend.margin = margin(t = 0))
149 |
150 | if (axis_line) {
151 | ret <- ret + theme(axis.line = element_line(color = "black", size = 0.25))
152 | }
153 |
154 | ret
155 | }
156 |
157 | equilibrium <- uniroot(function(x) supply_fun(x) - demand_fun(x), c(0, max_x))$root
158 | equilibrium_tax <- uniroot(function(x) supply_tax(x) - demand_fun(x), c(0, max_x))$root
159 |
160 | x_q_tax <- seq(0, equilibrium_tax, 0.1)
161 | x_q_dwl <- seq(equilibrium_tax, equilibrium, 0.1)
162 |
163 | surplus_labels <- tribble(
164 | ~x, ~y, ~text, ~fill,
165 | 1, midpoint(demand_fun(equilibrium_tax), max(demand_fun(x_q_tax))),
166 | names[1], nord_green,
167 | 1, midpoint(min(supply_fun(x_q_tax)), supply_fun(equilibrium_tax)),
168 | names[2], nord_lt_blue,
169 | equilibrium_tax + 1, midpoint(min(supply_fun(x_q_dwl)), max(demand_fun(x_q_dwl))),
170 | names[3], nord_purple,
171 | 1, midpoint(demand_fun(equilibrium), demand_fun(equilibrium_tax)),
172 | names[4], nord_yellow,
173 | 1, midpoint(supply_fun(equilibrium), supply_fun(equilibrium_tax)),
174 | names[5], nord_yellow
175 | )
176 |
177 |
178 | if (shaded) {
179 | base_plot <- ggplot(data = tibble(x = 0:max_x), mapping = aes(x = x)) +
180 | geom_ribbon(data = tibble(x = x_q_tax),
181 | aes(x = x,
182 | ymin = demand_fun(equilibrium_tax), ymax = demand_fun(x_q_tax)),
183 | alpha = 0.3, fill = nord_green) +
184 | geom_ribbon(data = tibble(x = x_q_tax),
185 | aes(x = x,
186 | ymin = supply_fun(x_q_tax), ymax = supply_fun(equilibrium_tax)),
187 | alpha = 0.3, fill = nord_lt_blue) +
188 | geom_ribbon(data = tibble(x = x_q_dwl),
189 | aes(x = x,
190 | ymin = supply_fun(x_q_dwl), ymax = demand_fun(x_q_dwl)),
191 | alpha = 0.3, fill = nord_purple) +
192 | geom_ribbon(data = tibble(x = x_q_tax),
193 | aes(x = x,
194 | ymin = demand_fun(equilibrium), ymax = demand_fun(equilibrium_tax)),
195 | alpha = 0.3, fill = nord_yellow) +
196 | geom_ribbon(data = tibble(x = x_q_tax),
197 | aes(x = x,
198 | ymin = supply_fun(equilibrium), ymax = supply_fun(equilibrium_tax)),
199 | alpha = 0.3, fill = nord_yellow)
200 | } else {
201 | base_plot <- ggplot(data = tibble(x = 0:max_x), mapping = aes(x = x))
202 | }
203 |
204 | full_plot <- base_plot +
205 | geom_segment(aes(x = equilibrium, xend = equilibrium,
206 | y = -Inf, yend = supply_fun(equilibrium)),
207 | color = "grey50", size = 0.5, linetype = "dashed") +
208 | geom_segment(aes(x = -Inf, xend = equilibrium,
209 | y = supply_fun(equilibrium), yend = supply_fun(equilibrium)),
210 | color = "grey50", size = 0.5, linetype = "dashed") +
211 | geom_segment(aes(x = equilibrium_tax, xend = equilibrium_tax,
212 | y = -Inf, yend = supply_tax(equilibrium_tax)),
213 | color = "grey50", size = 0.5, linetype = "dashed") +
214 | geom_segment(aes(x = -Inf, xend = equilibrium_tax,
215 | y = supply_tax(equilibrium_tax), yend = supply_tax(equilibrium_tax)),
216 | color = "grey50", size = 0.5, linetype = "dashed") +
217 | geom_segment(aes(x = -Inf, xend = equilibrium_tax,
218 | y = supply_fun(equilibrium_tax), yend = supply_fun(equilibrium_tax)),
219 | color = "grey50", size = 0.5, linetype = "dashed") +
220 | stat_function(fun = supply_fun, size = 1.5, color = nord_red) +
221 | stat_function(fun = supply_tax, size = 1.5, color = nord_orange) +
222 | stat_function(fun = demand_fun, size = 1.5, color = nord_dk_blue) +
223 | annotate(geom = "label", x = 38, y = supply_fun(38), label = "S",
224 | size = 4, fill = nord_red, color = "white") +
225 | annotate(geom = "label", x = 38, y = supply_tax(38), label = "S[tax]",
226 | size = 4, fill = nord_orange, color = "white", parse = TRUE) +
227 | annotate(geom = "label", x = 38, y = demand_fun(38), label = "D",
228 | size = 4, fill = nord_dk_blue, color = "white") +
229 | scale_x_continuous(expand = c(0, 0)) +
230 | scale_y_continuous(expand = c(0, 0), labels = scales::dollar) +
231 | coord_cartesian(xlim, ylim) +
232 | labs(x = xlab, y = ylab, title = title) +
233 | theme_econ(13, axis_line = TRUE) +
234 | theme(panel.grid = element_blank(),
235 | plot.background = element_rect(fill = bg.col),
236 | plot.margin = margin(0.5, 1, 0.5, 0.5, "cm"))
237 |
238 | if (shaded) {
239 | final_plot <- full_plot +
240 | geom_label(data = surplus_labels, aes(x = x, y = y, label = text, fill = fill),
241 | hjust = "left", size = 4, color = "white") +
242 | scale_fill_identity()
243 | } else {
244 | final_plot <- full_plot
245 | }
246 |
247 | coordinates <- list(qstar_comp = equilibrium,
248 | pstar_comp = demand_fun(equilibrium),
249 | qstar_tax = equilibrium_tax,
250 | pstar_tax = demand_fun(equilibrium_tax),
251 | psupplied_tax = supply_fun(equilibrium_tax))
252 |
253 | # Consumer surplus pre tax
254 | con_surplus_height <- demand_fun(0) - coordinates$pstar_comp
255 | con_surplus_base <- coordinates$qstar_comp
256 | con_surplus <- 0.5 * con_surplus_base * con_surplus_height
257 |
258 | # Consumer surplus post tax
259 | con_surplus_tax_height <- demand_fun(0) - coordinates$pstar_tax
260 | con_surplus_tax_base <- coordinates$qstar_tax
261 | con_surplus_tax <- 0.5 * con_surplus_tax_base * con_surplus_tax_height
262 |
263 | # Producer surplus pre tax
264 | pro_surplus_height <- coordinates$pstar_comp - supply_fun(0)
265 | pro_surplus_base <- coordinates$qstar_comp
266 | pro_surplus <- 0.5 * pro_surplus_base * pro_surplus_height
267 |
268 | # Producer surplus pre tax
269 | pro_surplus_tax_height <- coordinates$psupplied_tax - supply_fun(0)
270 | pro_surplus_tax_base <- coordinates$qstar_tax
271 | pro_surplus_tax <- 0.5 * pro_surplus_tax_base * pro_surplus_tax_height
272 |
273 | # DWL
274 | dwl_height <- coordinates$pstar_tax - coordinates$psupplied_tax
275 | dwl_base <- coordinates$qstar_comp - coordinates$qstar_tax
276 | dwl <- 0.5 * dwl_base * dwl_height
277 |
278 | # Tax incidence
279 | incidence_base <- coordinates$qstar_tax
280 | con_incidence_height <- coordinates$pstar_tax - coordinates$pstar_comp
281 | pro_incidence_height <- coordinates$pstar_comp - coordinates$psupplied_tax
282 |
283 | con_incidence <- incidence_base * con_incidence_height
284 | pro_incidence <- incidence_base * pro_incidence_height
285 | total_incidence <- con_incidence + pro_incidence
286 | con_incidence_pct <- con_incidence / total_incidence
287 | pro_incidence_pct <- pro_incidence / total_incidence
288 |
289 | areas <- list(con_surplus = con_surplus,
290 | con_surplus_tax = con_surplus_tax,
291 | pro_surplus = pro_surplus,
292 | pro_surplus_tax = pro_surplus_tax,
293 | dwl = dwl,
294 | con_incidence = con_incidence,
295 | pro_incidence = pro_incidence,
296 | total_incidence = total_incidence,
297 | con_incidence_pct = con_incidence_pct,
298 | pro_incidence_pct = pro_incidence_pct)
299 |
300 | areas_intermediate <- list(con_surplus_height = con_surplus_height,
301 | con_surplus_base = con_surplus_base,
302 | con_surplus_tax_height = con_surplus_tax_height,
303 | con_surplus_tax_base = con_surplus_tax_base,
304 | pro_surplus_height = pro_surplus_height,
305 | pro_surplus_base = pro_surplus_base,
306 | pro_surplus_tax_height = pro_surplus_tax_height,
307 | pro_surplus_tax_base = pro_surplus_tax_base,
308 | dwl_height = dwl_height,
309 | dwl_base = dwl_base,
310 | incidence_base = incidence_base,
311 | con_incidence_height = con_incidence_height,
312 | pro_incidence_height = pro_incidence_height)
313 |
314 | return(list(p = final_plot, coordinates = coordinates,
315 | areas = areas, areas_intermediate = areas_intermediate,
316 | details = print_details(coordinates, areas, areas_intermediate)))
317 | }
318 |
319 |
320 |
321 |
--------------------------------------------------------------------------------
/R/zzz.R:
--------------------------------------------------------------------------------
1 | #===================
2 | # On load
3 | #===================
4 | .onAttach <- function(libname, pkgname) {
5 | packageStartupMessage("~~ Package econocharts\nVisit https://r-coder.com/ for R tutorials ~~")
6 | }
7 |
--------------------------------------------------------------------------------
/README.md:
--------------------------------------------------------------------------------
1 | # econocharts package
2 | Microeconomics/macroeconomics graphs made with ggplot2
3 |
4 | This package allows creating microeconomics or macroeconomics charts in R with simple functions. This package inspiration is [reconPlots](https://github.com/andrewheiss/reconPlots) by Andrew Heiss.
5 |
6 | THE PACKAGE IS UNDER HEAVY DEVELOPMENT. WORK IN PROGRESS. You can suggest ideas by submitting an Issue or contributing submitting Pull Requests.
7 |
8 | ## TODO
9 | - [ ] Finish documentation
10 | - [x] Price control (in `sdcurve` function)
11 | - [ ] Allow drawing custom functions
12 | - [ ] Add graph for budget constraints
13 | - [ ] Fix `linecol` argument
14 | - [x] Tax graph
15 | - [ ] Shade producer and consumer surplus
16 | - [ ] Add Edgeworth box
17 | - [ ] General equilibrium (suggested by Ilya)
18 | - [x] Prospect theory value function (suggested by @brshallo)
19 | - [x] Neoclassical labor supply (suggested by @hilton1)
20 |
21 |
22 | ## Index
23 | - [Installation](#installation)
24 | - [Supply curve](#supply)
25 | - [Demand curve](#demand)
26 | - [Supply and demand](#supply-and-demand)
27 | - [Neoclassical labor supply](#neoclassical-labor-supply)
28 | - [Indifference curves](#indifference-curves)
29 | - [Production–possibility frontier](#productionpossibility-frontier)
30 | - [Tax graph](#tax-graph)
31 | - [Prospect Theory value function](#prospect-theory-value-function)
32 | - [Laffer curve](#laffer-curve)
33 | - [Calculating the intersections](#intersections)
34 | - [Citation](#citation)
35 |
36 | ## Installation
37 |
38 | ### GitHub
39 | ```r
40 | # Install the development version from GitHub:
41 | # install.packages("devtools")
42 | devtools::install_github("R-CoderDotCom/econocharts")
43 | ```
44 |
45 | ### CRAN
46 | The package will be on CRAN as soon as possible
47 |
48 | ## Supply
49 |
50 | ```r
51 | supply() # Default plot
52 | ```
53 |
54 |
55 |
56 |
70 |
71 |
81 |
82 |
92 |
93 |
106 |
107 |
117 |
118 |
146 |
147 |
156 |
157 |
166 |
167 |
180 |
181 |
195 |
196 |
211 |
212 |
228 |
229 |
245 |
246 |
268 |
269 |
285 |
286 |
294 |
295 |
313 |
314 |
326 |
327 |
343 |
344 |
375 |
376 |
404 |
405 |