带双轴的ggplot2

Question

这是this问题的扩展。我目前正在使用CRAN的最新版ggplot2（v2.2.0）在R内创建绘图。

我正在使用@Axeman here提供的解决方案。

我遇到的麻烦是，当我使用facet时，有时y轴中的一个显示非常小的值。我想知道是否有人有一个干净的解决方案，以便两个y轴可以适当缩放。

可重复的例子：

library(data.table)
library(ggplot2)
library(scales)

dt1 <- data.table(diamonds)
dt1 <- dt1[, .(averageprice = mean(price), numstones  =.N, Group = "Trend"), 
           by = color]

dt2 <- data.table(diamonds)
dt2 <- dt2[cut == "Premium", .(averageprice = mean(price), numstones = .N, Group = "Premium"), 
           by = color]

dt1 <- rbindlist(list(dt1, dt2))
setkey(dt1, color)

# rescale axes for plotting
max_left <- max(dt1[, sum(averageprice), by = .(Group, color)]$V1)
max_right <- max(dt1[, sum(numstones), by = .(Group, color)]$V1)
dt1$right <- dt1$numstones / (max_right / max_left)

dt1
# color averageprice numstones   Group     right
#     D     3169.954      6775   Trend 3776.6435
#     D     3631.293      1603 Premium  893.5734
#     E     3076.752      9797   Trend 5461.2216
#     E     3538.914      2337 Premium 1302.7330
#     F     3724.886      9542   Trend 5319.0748
#     F     4324.890      2331 Premium 1299.3883
#     G     3999.136     11292   Trend 6294.5916
#     G     4500.742      2924 Premium 1629.9491
#     H     4486.669      8304   Trend 4628.9664
#     H     5216.707      2360 Premium 1315.5540
#     I     5091.875      5422   Trend 3022.4296
#     I     5946.181      1428 Premium  796.0217
#     J     5323.818      2808   Trend 1565.2863
#     J     6294.592       808 Premium  450.4100

p <- ggplot()
p <- p + geom_col(data = dt1, aes(color, averageprice, fill = "myfill"))
p <- p + geom_point(data = dt1, aes(color, right, colour = "mycolour"))
p <- p + scale_y_continuous(sec.axis = sec_axis(trans = ~ . * (max_right / max_left),
                                                name = 'number of stones'))
p <- p + scale_fill_manual(name = "", labels = "Average Price", values = "#00AEFF")
p <- p + scale_colour_manual(name = "", labels = "Number of Stones", values = "#3c3c3c")
p <- p + guides(fill = guide_legend(order = 1))
p <- p + facet_wrap(~ Group, scales = "free_y")
p <- p + theme(legend.position = "bottom")
p

我希望能够做到的是让Premium facet的右手轴具有更接近数据的最大值（大约4000）。显然不想硬编码。

非常感谢任何指导。