R, ggplot2: Как построить кривые Безье, проходящие через фиксированные координаты?

Я помогаю кому-то перевести нарисованные от руки функции спроса и предложения в области экономики в файлы изображений, которые можно включить в документ Word. Они хорошо работают с использованием Hmisc::bezier и geom_path, смоделированных на основе разведывательных графиков Эндрю Хейса, и с использованием его функции curve_intersect. То есть до тех пор, пока автор не потребовал, чтобы одна из кривых предложения проходила через заданный набор координат. Функция Hmisc::bezier использует только первую и последнюю контрольные точки как абсолютные и изгибается к промежуточным точкам, поэтому указанная точка пересечения не соответствует кривой. Я попытался создать сплайн из двух кривых Безье с помощью функции Безье из пакета Безье (v1.1.2, https://cran.r-project.org/web/packages/bezier/bezier.pdf), но это не удается с ошибкой в ​​FUN(X[[i]], .. .) : объект 'x' не найден, что я не понимаю или не знаю, как исправить.

Пожалуйста, дайте мне знать, где я ошибаюсь или есть ли лучший метод! Я буду включать закомментированные попытки использования различных функций. Пожалуйста, извините за дилетантский код, так как я новичок в R и ggplot2.

Этот раздел не имеет прямого отношения к моему вопросу

# Graph figures for physical economics, negative oil prices paper

library(reconPlots)
library(dplyr)
library(ggplot2)
library(patchwork)
library(ggrepel)
library(bezier)
library(ggforce)

options(ggrepel.max.time = 1)
options(ggrepel.max.iter = 20000)

#Set seed value for ggrepel
set.seed(52)

# panel (a) 

#Set values of curves using the bezier function, each pair of c() values
# is an xy coordinate, and the sets of coordinates control the shape of the
# curve
supply <- Hmisc::bezier(c(1, 5, 6), c(3, 4, 9)) %>%
  as_data_frame()

demand <- Hmisc::bezier(c(0, 9, 9), c(6, 6, 6)) %>%
  as_data_frame()

label_height <- Hmisc::bezier(c(0, 9, 9), c(8, 8, 8)) %>%
  as_data_frame()

# Calculate the intersections of the two curves
intersections <- bind_rows(curve_intersect(supply, demand))

# Calculate point where the curve label(s) intersect a specified height
supply_label <- bind_rows(curve_intersect(supply, label_height))

labels <- data_frame(label = expression("PS"[CR]^DRL),
                     x = supply_label$x,
                     y = supply_label$y)                      

production <- ggplot(mapping = aes(x = x, y = y)) + 
  #Draw the supply curve. Demand is not drawn in this figure, but the
  # intersections of an imaginary demand curve are used to illustrate P0
  # and Q0, the intersection point, and the dotted lines
  geom_path(data = supply, color = "#0073D9", size = 1) + 
  geom_segment(data = intersections, 
               aes(x = x, y = 0, xend = x, yend = y), lty = "dotted") +
  geom_segment(data = intersections, 
               aes(x = 0, y = y, xend = x, yend = y), lty = "dotted") + 
  #Draw the supply curve label using the intersection calculated above, using
  # GGrepel so that the labels do not overlap the curve line
  geom_text_repel(data = labels
                  ,aes(x = x, y = y, label = label) 
                  ,parse = TRUE
                  ,direction = "x"
                  ,force = 3
                  ,force_pull = 0.1
                  ,hjust = 0
                  ,min.segment.length = 0
  ) +
  #Draw the intersection point based on intersection function between supply
  # and the phantom flat demand curve at height y=6
  geom_point(data = intersections, size = 3) +
  #Use scale functions to set y-axis label, axis intersection point labels,
  # and limits of the viewing area
  scale_x_continuous(expand = c(0, 0), breaks = intersections$x
                     ,labels = expression(Q[CR]^{DRL-PS})
                     ,limits=c(0,9)
  ) +
  scale_y_continuous(expand = c(0, 0), breaks = c(intersections$y, 9)
                     ,labels = c(expression(P[CR]==frac("$",brl))
                                 ,expression(P[CR]))
                     ,limits=c(0,9)
  ) +
  #Use labs function to set x-axis title and title of each graph using the
  # caption function so that it displays on the bottom
  labs(x = expression(frac(Barrels,Week)),
       caption = expression(atop("(a) Driller Production Supply", "of Crude Oil"))
  ) +
  #Set classic theme, x-axis title on right-hand side using larger font of
  # relative size 1.2, graph title on left-hand side using same larger font
  theme_classic() + 
  theme(axis.title.y = element_blank(),
        axis.title.x = element_text(hjust = 1), 
        axis.text = element_text(size=rel(1.2)),
        plot.caption = element_text(hjust = 0.5, size=rel(1.2))
  ) + 
  coord_equal()

# Save the intersections so we can set the same quantity, price for panel (c)
specified_intersections = intersections

# Panel (b)
supply <- Hmisc::bezier(c(3.99, 4), c(0, 9)) %>%
  as_data_frame()

demand <- Hmisc::bezier(c(2, 3, 4, 5), c(9, 6.5, 6, 5.5)) %>%
  as_data_frame()

demand_capacity <- Hmisc::bezier(c(5, 5), c(0, 5.5)) %>%
  as_data_frame()

supply_capacity <- Hmisc::bezier(c(4.999, 5), c(0, 9)) %>%
  as_data_frame()

supply_label_height <- Hmisc::bezier(c(0, 9), c(9, 9)) %>%
  as_data_frame()

demand_label_height <- Hmisc::bezier(c(0, 9), c(8, 8)) %>%
  as_data_frame()

capacity_label_height <- Hmisc::bezier(c(0, 9), c(9, 9)) %>%
  as_data_frame()

# Calculate the intersections of the two curves
intersections <- bind_rows(curve_intersect(supply, 
                                           demand))

supply_label <- bind_rows(curve_intersect(supply 
                                          ,supply_label_height))
demand_label <- bind_rows(curve_intersect(demand 
                                          ,demand_label_height))
capacity_label <- bind_rows(curve_intersect(supply_capacity 
                                            ,capacity_label_height))

labels <- data_frame(label = c(expression("OD"[CR]^DRL),expression("OS"[CR]^DRL)
                               ,expression("Q"[CR]^CAP)
),
x = c(demand_label$x, supply_label$x
      , capacity_label$x
),
y = c(demand_label$y, supply_label$y
      , capacity_label$y
)
) 

inventory <- ggplot(mapping = aes(x = x, y = y)) + 
  geom_path(data = supply, color = "#0073D9", size = 1) + 
  geom_path(data = demand, color = "#FF4036", size = 1) +
  geom_path(data = demand_capacity, color = "#FF4036", size = 1) +
  geom_path(data = supply_capacity, color = "#0073D9", size = 1, lty = "dashed") +
  geom_segment(data = intersections, 
               aes(x = 0, y = y, xend = x, yend = y), lty = "dotted") + 
  geom_text_repel(data = labels
                  ,aes(x = x, y = y, label = label) 
                  ,parse = TRUE
                  ,direction = "x"
                  ,force = 3
                  ,force_pull = 0.1
                  ,hjust = c(0, 0, 1)
                  ,min.segment.length = 0
  ) +
  geom_point(data = intersections, size = 3) +
  scale_x_continuous(expand = c(0, 0), breaks = c(intersections$x
                                                  , 5),
                     labels = c(expression(paste(Q[CR]^{DRL-OS},phantom(12345)))
                                ,expression(Q[CR]^CAP)
                     )
                     , limits=c(0,9)) +
  scale_y_continuous(expand = c(0, 0), breaks = c(intersections$y, 9),
                     labels = c(expression(P[CR]),expression(P[CR]))
                     , limits=c(0,9)) +
  labs(x = "Barrels",
       caption = expression(atop("(b) Driller Storage / Ownership", "of Crude Oil"))
  ) +
  theme_classic() + 
  theme(axis.title.y = element_blank(),
        axis.title.x = element_text(hjust = 1), 
        axis.text = element_text(size=rel(1.2)),
        plot.caption = element_text(hjust = 0.5, size=rel(1.2))
  ) + 
  coord_equal()  

Соответствующий раздел


# panel (c)

# ggforce package method
#supply <- list(c(1, 4, specified_intersections$x, 5, 7),
#                        c(3, 4, specified_intersections$y, 7, 9)) %>%
#  as_data_frame()

# bezier package method: Fails with "Error in FUN(X[[i]], ...) : object 'x' not found"
t <- seq(0, 2, length=10)
p <- list(c(1, 4, specified_intersections$x, 7, 8), 
          c(3, 4, specified_intersections$y, 6, 9))
#p <- matrix(c(1,3, 4,4, specified_intersections$x,specified_intersections$y,
#              7,6, 8,9), nrow=5, ncol=2, byrow=TRUE)
supply <- bezier(t=t, p=p) %>%
  as_data_frame()

# Original: Fails because it does not pass through the specified intersection
#supply <- Hmisc::bezier(c(1, specified_intersections$x, 8), 
#                        c(3, specified_intersections$y, 9)) %>%
#  as_data_frame()

# Hmisc method: Fails because there is no way to get the two curves to appear
# contiguous
#supply1 <- Hmisc::bezier(c(1, 4, specified_intersections$x), 
#                         c(3, 4, specified_intersections$y)) %>%
#  as_data_frame()
#supply2 <- Hmisc::bezier(c(specified_intersections$x, 6, 7), 
#                         c(specified_intersections$y, 8, 9)) %>%
#  as_data_frame()

#demand <- Hmisc::bezier(c(0, 9), c(specified_intersections$y, specified_intersections$y)) %>%
#  as_data_frame()

label_height <- Hmisc::bezier(c(0, 9), c(8, 8)) %>%
  as_data_frame()

# Calculate the intersections of the two curves
#intersections <- bind_rows(curve_intersect(supply, demand))

#supply_label <- bind_rows(curve_intersect(supply, 
#                                          label_height))

#labels <- data_frame(label = expression("SS"[CR]^DRL),
#                     x = supply_label$x,
#                     y = supply_label$y)                      

sales <- ggplot(mapping = aes(x = x, y = y)) + 
# ggforce package method
#  geom_bspline(data = supply, color = "#0073D9", size = 1) +
  
# Original geom_path method  
  geom_path(data = supply, color = "#0073D9", size = 1) + 
# Supply 1 and 2 for Hmisc method
#  geom_path(data = supply1, color = "#0073D9", size = 1) + 
#  geom_path(data = supply2, color = "#0073D9", size = 1) + 
  geom_segment(data = specified_intersections, 
               aes(x = x, y = 0, xend = x, yend = y), lty = "dotted") +
  geom_segment(data = specified_intersections, 
               aes(x = 0, y = y, xend = x, yend = y), lty = "dotted") + 
#  geom_text_repel(data = labels
#                  ,aes(x = x, y = y, label = label) 
#                  ,parse = TRUE
#                  ,direction = "x"
#                  ,force = 3
#                  ,force_pull = 0.1
#                  ,hjust = 0
#                  ,min.segment.length = 0
#  ) +
  geom_point(data = specified_intersections, size = 3) +
  scale_x_continuous(expand = c(0, 0), breaks = specified_intersections$x,
                     labels = expression(Q[CR]^{DRL-SS}), limits=c(0,9)) +
  scale_y_continuous(expand = c(0, 0), breaks = c(specified_intersections$y, 9),
                     labels = c(expression(P[CR]),expression(P[CR]))) +
  labs(x = expression(frac(Barrels,Week)),
       caption = expression(atop("(c) Driller Sales Supply", "of Crude Oil"))
  ) +
  theme_classic() + 
  theme(axis.title.y = element_blank(),
        axis.title.x = element_text(hjust = 1), 
        axis.text = element_text(size=rel(1.2)),
        plot.caption = element_text(hjust = 0.5, size=rel(1.2))
  ) + 
  coord_equal()  

patchwork <- (production | inventory | sales)
patchwork

Графики до внедрения фиксированных координат. Необходимо переместить точку пересечения панели (c) в соответствии с панелью (a)


person arthurtuxedo    schedule 18.02.2021    source источник
comment
Спасибо за предложения, Хенрик! Я разделил код на соответствующий раздел и остальную часть для удобства чтения. Я попробовал реализацию ggforce, но получил те же результаты, что и оригинальный Hmisc. Кривая не проходила через указанные точки пересечения.   -  person arthurtuxedo    schedule 19.02.2021


Ответы (1)


Я решил ошибку в FUN(X[[i]], ...): объект 'x' не найден, распечатав переменную поставки и заметив, что функция Безье называет свои строки V1, V2, а не x, y. Мне нужно было настроить эстетику geom_path на правильное отображение.

Соответствующий раздел, обрезанный только по методу Безье

# panel (c)

# bezier package method
t <- seq(0, 2, length = 100)
p <- matrix(c(1,3, 4,4, specified_intersections$x,specified_intersections$y,
              7,6, 8,9), nrow=5, ncol=2, byrow=TRUE)
supply <- bezier::bezier(t=t, p=p, deg=2) %>%
  as_data_frame()

sales <- ggplot(mapping = aes(x = x, y = y)) + 
  
# Original geom_path method  
  geom_path(data = supply, mapping = aes(x = V1, y = V2), 
            color = "#0073D9", size = 1, inherit.aes = FALSE) + 
  geom_segment(data = specified_intersections, 
               aes(x = x, y = 0, xend = x, yend = y), lty = "dotted") +
  geom_segment(data = specified_intersections, 
               aes(x = 0, y = y, xend = x, yend = y), lty = "dotted") + 

  geom_point(data = specified_intersections, size = 3) +
  scale_x_continuous(expand = c(0, 0), breaks = specified_intersections$x,
                     labels = expression(Q[CR]^{DRL-SS}), limits=c(0,9)) +
  scale_y_continuous(expand = c(0, 0), breaks = c(specified_intersections$y, 9),
                     labels = c(expression(P[CR]),expression(P[CR]))) +
  labs(x = expression(frac(Barrels,Week)),
       caption = expression(atop("(c) Driller Sales Supply", "of Crude Oil"))
  ) +
  theme_classic() + 
  theme(axis.title.y = element_blank(),
        axis.title.x = element_text(hjust = 1), 
        axis.text = element_text(size=rel(1.2)),
        plot.caption = element_text(hjust = 0.5, size=rel(1.2))
  ) + 
  coord_equal()  

patchwork <- (production | inventory | sales)
patchwork

Это не решает моей более серьезной проблемы, связанной с необходимостью гладкой кривой, проходящей через указанный набор координат, поскольку создает две кривые Безье, которые не совпадают.

Я проведу некоторое исследование использования функций для задания кривых Безье и выясню, существует ли какой-нибудь математический или программный способ задать кривую Безье, проходящую через набор фиксированных координат. Если я найду его, я отредактирую этот ответ.

Если кто-нибудь знает, как это сделать, буду признателен за любую помощь!

Изогнутые кривые Безье

person arthurtuxedo    schedule 21.02.2021