second y axis with linechart

R/as_series.R

@@ -20,7 +20,7 @@ series_wb_data <- function(dataset, idx) {
  serie_range
 }
 
-as_series <- function(x, x_class, y_class, sheetname = "sheet1") {
+as_series <- function(x, x_class, y_class, sheetname = "sheet1", secondary = NULL) {
  dataset <- x$data_series
 
  w_x <- which(names(dataset) %in% x$xvar)
@@ -89,9 +89,12 @@ as_series <- function(x, x_class, y_class, sheetname = "sheet1") {
  }
 
  ser <- list(
- idx = length(series), order = length(series),
+ idx = length(series) + secondary,
+ order = length(series) + secondary,
  tx = serie_name,
- x = x_serie, y = y_serie, label = label_serie,
+ x = x_serie,
+ y = y_serie,
+ label = label_serie,
  stroke = x$series_settings$colour[y_colname],
  fill = x$series_settings$fill[y_colname],
  symbol = x$series_settings$symbol[y_colname],

R/ms_chart.R

@@ -238,15 +238,16 @@ ms_chart <- function(data, x, y, group = NULL, labels = NULL,
  )
  tryCatch(
  {
- y_axis_tag <- get_axis_tag(data_y)
+ y_l_axis_tag <- get_axis_tag(data_y)
  },
  error = function(e) {
  stop("column ", shQuote(y), ": ", e$message, " [", paste(class(data_y), collapse = ","), "]", call. = FALSE)
  }
  )
 
  x_axis_ <- axis_options(axis_position = "b")
- y_axis_ <- axis_options(axis_position = "l")
+ x_r_axis_ <- axis_options(axis_position = "b", delete = 1L)
+ y_l_axis_ <- axis_options(axis_position = "l")
 
  x <- x[1]
  y <- y[1]
@@ -255,14 +256,19 @@ ms_chart <- function(data, x, y, group = NULL, labels = NULL,
  lbls <- list(title = NULL, x = x, y = y)
 
  out <- list(
- data = data, x = x, y = y, group = group, label_cols = labels,
+ data = data,
+ x = x,
+ y = y,
+ group = group,
+ label_cols = labels,
  theme = theme_,
  options = list(),
  x_axis = x_axis_,
- y_axis = y_axis_,
+ x_r_axis = x_r_axis_,
+ y_l_axis = y_l_axis_,
  axis_tag = list(
  x = x_axis_tag,
- y = y_axis_tag
+ y = y_l_axis_tag
  ),
  fmt_names = list(
  x = fmt_name(data_x),
@@ -377,38 +383,94 @@ colour_list <- list(
 #' @method format ms_chart
 #' @export
 format.ms_chart <- function(x, id_x, id_y, sheetname = "sheet1", drop_ext_data = FALSE, ...) {
- str_ <- to_pml(x, id_x = id_x, id_y = id_y, sheetname = sheetname, asis = x$asis)
+ str_l <- to_pml(x, id_x = id_x, id_y = id_y, sheetname = sheetname, asis = x$asis, secondary = 0)
 
  if (is.null(x$x_axis$num_fmt)) {
  x$x_axis$num_fmt <- x$theme[[x$fmt_names$x]]
  }
- if (is.null(x$y_axis$num_fmt)) {
- x$y_axis$num_fmt <- x$theme[[x$fmt_names$y]]
+ if (is.null(x$y_l_axis$num_fmt)) {
+ x$y_l_axis$num_fmt <- x$theme[[x$fmt_names$y]]
  }
 
- x_axis_str <- axis_content_xml(x$x_axis,
- id = id_x, theme = x$theme,
- cross_id = id_y, is_x = TRUE,
- lab = htmlEscape(x$labels$x), rot = x$theme$title_x_rot
+ x_axis_str <- axis_content_xml(
+ x$x_axis,
+ id = id_x,
+ theme = x$theme,
+ cross_id = id_y,
+ is_x = TRUE,
+ lab = htmlEscape(x$labels$x),
+ rot = x$theme$title_x_rot
  )
 
- x_axis_str <- sprintf("<%s>%s</%s>", x$axis_tag$x, x_axis_str, x$axis_tag$x)
+ x_l_axis_str <- sprintf("<%s>%s</%s>", x$axis_tag$x, x_axis_str, x$axis_tag$x)
 
- y_axis_str <- axis_content_xml(x$y_axis,
+ y_l_axis_str <- axis_content_xml(x$y_l_axis,
  id = id_y, theme = x$theme,
  cross_id = id_x, is_x = FALSE,
  lab = htmlEscape(x$labels$y), rot = x$theme$title_y_rot
  )
 
- y_axis_str <- sprintf("<%s>%s</%s>", x$axis_tag$y, y_axis_str, x$axis_tag$y)
+ y_l_axis_str <- sprintf("<%s>%s</%s>", x$axis_tag$y, y_l_axis_str, x$axis_tag$y)
+
+ str_r <- NULL
+ y_r_axis_str <- NULL
+ x_r_axis_str <- NULL
+
+ if (!is.null(x$secondary)) {
+
+ str_r <- to_pml(
+ x$secondary,
+ id_y = "320476559",
+ id_x = "67917199",
+ sheetname = sheetname,
+ asis = x$secondary$asis,
+ secondary = length(x$yvar)
+ )
+
+ x$secondary$y_l_axis <- axis_options(axis_position = "r", crosses = "max")
+
+ y_r_axis_str <- axis_content_xml(
+ x$secondary$y_l_axis,
+ id = "320476559",
+ theme = x$theme,
+ cross_id = "67917199",
+ is_x = FALSE,
+ lab = htmlEscape(x$secondary$labels$y),
+ rot = x$secondary$theme$title_y_rot
+ )
+
+ y_r_axis_str <- sprintf("<%s>%s</%s>", x$secondary$axis_tag$y, y_r_axis_str, x$secondary$axis_tag$y)
+
+ x_r_axis_str <- axis_content_xml(
+ x$secondary$x_r_axis,
+ id = "67917199",
+ theme = x$secondary$theme,
+ cross_id = "320476559",
+ is_x = TRUE,
+ lab = NULL
+ )
+ x_r_axis_str <- sprintf("<%s>%s</%s>", x$secondary$axis_tag$x, x_r_axis_str, x$secondary$axis_tag$x)
+ }
 
 
  table_str <- table_content_xml(x)
 
  sppr_str <- sppr_content_xml(x$theme, "plot")
 
  ns <- "xmlns:c=\"https://schemas.openxmlformats.org/drawingml/2006/chart\" xmlns:a=\"https://schemas.openxmlformats.org/drawingml/2006/main\" xmlns:r=\"https://schemas.openxmlformats.org/officeDocument/2006/relationships\""
- xml_elt <- paste0("<c:plotArea ", ns, "><c:layout/>", str_, x_axis_str, y_axis_str, table_str, sppr_str, "</c:plotArea>")
+
+ xml_elt <- paste0(
+ "<c:plotArea ", ns, "><c:layout/>",
+ str_l,
+ str_r,
+ x_l_axis_str,
+ y_l_axis_str,
+ y_r_axis_str,
+ x_r_axis_str,
+ table_str,
+ sppr_str
+ "</c:plotArea>"
+ )
  xml_doc <- read_xml(system.file(package = "mschart", "template", "chart.xml"))
 
  node <- xml_find_first(xml_doc, "//c:plotArea")

R/to_pml.R

@@ -1,7 +1,7 @@
 clustered_pos <- c("ctr", "inBase", "inEnd", "outEnd")
 stacked_pos <- c("ctr", "inBase", "inEnd")
 
-to_pml.ms_barchart <- function(x, id_x, id_y, sheetname = "sheet1", add_ns = FALSE, ...){
+to_pml.ms_barchart <- function(x, id_x, id_y, sheetname = "sheet1", add_ns = FALSE, secondary = 0, ...){
 
  if( "clustered" %in% x$options$grouping )
  if( !x$label_settings$position %in% clustered_pos ){
@@ -16,8 +16,13 @@ to_pml.ms_barchart <- function(x, id_x, id_y, sheetname = "sheet1", add_ns = FAL
  paste(shQuote(stacked_pos), collapse = ", "), ".", call. = FALSE)
  }
 
- series <- as_series(x, x_class = serie_builtin_class(x$data[[x$x]]),
- y_class = serie_builtin_class(x$data[[x$y]]), sheetname = sheetname )
+ series <- as_series(
+ x,
+ x_class = serie_builtin_class(x$data[[x$x]]),
+ y_class = serie_builtin_class(x$data[[x$y]]),
+ sheetname = sheetname,
+ secondary = secondary
+ )
 
  str_series_ <- sapply( series, function(serie, template ){
  marker_str <- get_sppr_xml(serie$fill, serie$stroke, serie$line_width )
@@ -31,8 +36,8 @@ to_pml.ms_barchart <- function(x, id_x, id_y, sheetname = "sheet1", add_ns = FAL
 
  paste0(
  "<c:ser>",
- sprintf("<c:idx val=\"%.0f\"/>", serie$idx),
- sprintf("<c:order val=\"%.0f\"/>", serie$order),
+ sprintf("<c:idx val=\"%.0f\"/>", max(0, serie$idx)),
+ sprintf("<c:order val=\"%.0f\"/>", max(0, serie$order)),
  sprintf("<c:tx>%s</c:tx>", to_pml(serie$tx)),
  marker_str,
  "<c:invertIfNegative val=\"0\"/>",
@@ -64,16 +69,21 @@ to_pml.ms_barchart <- function(x, id_x, id_y, sheetname = "sheet1", add_ns = FAL
 }
 
 standard_pos <- c("b", "ctr", "l", "r", "t")
-to_pml.ms_linechart <- function(x, id_x, id_y, sheetname = "sheet1", add_ns = FALSE, ...){
+to_pml.ms_linechart <- function(x, id_x, id_y, sheetname = "sheet1", add_ns = FALSE, secondary = 0, ...){
 
  if( !x$label_settings$position %in% standard_pos ){
  stop("label position issue.",
  "Arg. position in chart_data_labels() should match one of ",
  paste(shQuote(standard_pos), collapse = ", "), ".", call. = FALSE)
  }
 
- series <- as_series(x, x_class = serie_builtin_class(x$data[[x$x]]),
- y_class = serie_builtin_class(x$data[[x$y]]), sheetname = sheetname )
+ series <- as_series(
+ x,
+ x_class = serie_builtin_class(x$data[[x$x]]),
+ y_class = serie_builtin_class(x$data[[x$y]]),
+ sheetname = sheetname,
+ secondary = secondary
+ )
 
  # sapply linec-----
  str_series_ <- sapply( series, function(serie, has_line, has_marker ){
@@ -100,7 +110,10 @@ to_pml.ms_linechart <- function(x, id_x, id_y, sheetname = "sheet1", add_ns = FA
  sprintf("<c:idx val=\"%.0f\"/>", serie$idx),
  sprintf("<c:order val=\"%.0f\"/>", serie$order),
  sprintf("<c:tx>%s</c:tx>", to_pml(serie$tx)),
- line_str, marker_str,
+ # ifelse(secondary, line_str, ""),
+ line_str,
+ marker_str,
+ # ifelse(secondary, to_pml(label_settings, show_label = !is.null(x$label_cols)), ""),
  to_pml(label_settings, show_label = !is.null(x$label_cols)),
  "<c:cat>", to_pml(serie$x), "</c:cat>",
  "<c:val>", to_pml(serie$y), "</c:val>",
@@ -127,10 +140,15 @@ to_pml.ms_linechart <- function(x, id_x, id_y, sheetname = "sheet1", add_ns = FA
 }
 
 
-to_pml.ms_areachart <- function(x, id_x, id_y, sheetname = "sheet1", add_ns = FALSE, ...){
+to_pml.ms_areachart <- function(x, id_x, id_y, sheetname = "sheet1", add_ns = FALSE, secondary = 0, ...){
 
- series <- as_series(x, x_class = serie_builtin_class(x$data[[x$x]]),
- y_class = serie_builtin_class(x$data[[x$y]]), sheetname = sheetname )
+ series <- as_series(
+ x,
+ x_class = serie_builtin_class(x$data[[x$x]]),
+ y_class = serie_builtin_class(x$data[[x$y]]),
+ sheetname = sheetname,
+ secondary = secondary
+ )
 
  str_series_ <- sapply( series, function(serie){
  marker_str <- get_sppr_xml(serie$fill, serie$stroke, serie$line_width)
@@ -175,7 +193,7 @@ names(has_markers) <- scatterstyles
 has_lines <- c(FALSE, TRUE, TRUE, FALSE, TRUE, TRUE)
 names(has_lines) <- scatterstyles
 
-to_pml.ms_scatterchart <- function(x, id_x, id_y, sheetname = "sheet1", add_ns = FALSE, asis = FALSE, ...){
+to_pml.ms_scatterchart <- function(x, id_x, id_y, sheetname = "sheet1", add_ns = FALSE, asis = FALSE, secondary = 0, ...){
 
  if( !x$label_settings$position %in% standard_pos ){
  stop("label position issue.",
@@ -188,7 +206,8 @@ to_pml.ms_scatterchart <- function(x, id_x, id_y, sheetname = "sheet1", add_ns =
  x,
  x_class = serie_builtin_class(sort(unname(unlist(x$data_series[x$xvar])))),
  y_class = serie_builtin_class(sort(unname(unlist(x$data_series[x$yvar])))),
- sheetname = sheetname
+ sheetname = sheetname,
+ secondary = 0
  )
  else
  series <- as_series(