[WIP] add ms_piechart

NAMESPACE

@@ -3,6 +3,7 @@
 S3method(chart_settings,ms_areachart)
 S3method(chart_settings,ms_barchart)
 S3method(chart_settings,ms_linechart)
+S3method(chart_settings,ms_piechart)
 S3method(chart_settings,ms_scatterchart)
 S3method(format,ms_chart)
 S3method(ph_with,ms_chart)
@@ -28,6 +29,7 @@ export(chart_theme)
 export(ms_areachart)
 export(ms_barchart)
 export(ms_linechart)
+export(ms_piechart)
 export(ms_scatterchart)
 export(mschart_theme)
 export(set_theme)

R/as_series.R

@@ -47,6 +47,12 @@ as_series <- function(x, x_class, y_class, sheetname = "sheet1") {
   series <- list()
 
   series_nams <- get_series_names(x)
+
+  if (!x$asis && inherits(x, "ms_piechart")) {
+    series_nams <- x$y
+    label_columns <- x$y
+  }
+
   if (x$asis) series_nams <- x$yvar
 
   w_y_values <- which(names(dataset) %in% series_nams)

R/chart_settings.R

@@ -164,3 +164,16 @@ chart_settings.ms_scatterchart <- function(x, vary_colors = FALSE, style = "mark
   x$options <- options
   x
 }
+
+#' @export
+#' @describeIn chart_settings linechart settings
+chart_settings.ms_piechart <- function(x, vary_colors = FALSE, grouping = "standard", table = FALSE, ...) {
+  if (!grouping %in% st_grouping) {
+    stop("grouping should be one of ", paste0(shQuote(st_grouping), collapse = ", "))
+  }
+  options <- list(vary_colors = vary_colors, grouping = grouping, table = table)
+  class(options) <- "piechart_options"
+
+  x$options <- options
+  x
+}

R/excel_series.R

@@ -93,8 +93,25 @@ transpose_series_bysplit <- function(x) {
   out
 }
 
+average_pie_series <- function(x) {
+  vars <- c(x$x, x$y)
+  group <- x$group
+  if (is.null(group)) {
+    group <- x$x
+  }
+
+  dat <- setDT(x$data)
+
+  expr <- paste0("mean(", x$y, ", na.rm = TRUE)")
+  expr <- paste("dat[,", expr, ", by = ", group, "]")
+  dat <- eval(parse(text = expr))
 
+  # setnames(dat, group, x$y)
+  setnames(dat, "V1", x$y)
 
+  out <- setDF(dat)
+  out
+}
 
 #' @importFrom stats as.formula
 #' @importFrom data.table as.data.table dcast.data.table setorderv setnames

R/ms_chart.R

@@ -165,12 +165,37 @@ ms_scatterchart <- function(data, x, y, group = NULL, labels = NULL, asis = FALS
   )
   class(out) <- c("ms_scatterchart", "ms_chart")
 
-  out <- chart_settings(out)
+  out <- chart_settings(out, vary_colors = TRUE)
 
   out
 }
 
 
+#' @title piechart object
+#' @description Creation of a piechart object that can be
+#' inserted in a 'Microsoft' document.
+#' @inheritParams ms_linechart
+#' @family 'Office' chart objects
+#' @seealso [chart_settings()], [chart_ax_x()], [chart_ax_y()],
+#' [chart_data_labels()], [chart_theme()], [chart_labels()]
+#' @export
+ms_piechart <- function(data, x, y, group = NULL, labels = NULL, asis = FALSE) {
+  out <- ms_chart(
+    data = data, x = x, y = y, group = group, labels = labels,
+    excel_data_setup = average_pie_series,
+    type = "pieplot", asis = asis
+  )
+  class(out) <- c("ms_piechart", "ms_chart")
+  out <- chart_settings(out, vary_colors = TRUE)
+
+  serie_names <- names(out$series_settings$colour)
+
+  values <- setNames(rep("transparent", length(serie_names)), serie_names)
+  out <- chart_data_stroke(out, values = values)
+
+  out
+}
+
 # ms_chart -----
 
 #' @importFrom grDevices colors
@@ -215,7 +240,7 @@ ms_chart <- function(data, x, y, group = NULL, labels = NULL,
     data_y <- data[[y]]
   }
 
-  if (type == "areaplot" || type == "barplot") {
+  if (type == "areaplot" || type == "barplot" || type == "pieplot") {
     assert_area(data_x, data_y)
   }
 

R/to_pml.R

@@ -303,3 +303,76 @@ get_sppr_xml_line_chart <- function( fill, stroke, style, width){
          line_str,
          "</c:spPr>" )
 }
+
+
+# copy of areachart
+to_pml.ms_piechart <- function(x, id_x, id_y, sheetname = "sheet1", add_ns = FALSE, asis = FALSE, ...){
+
+  series <- as_series(
+    x,
+    x_class = serie_builtin_class(x$data_series[[x$x]]),
+    y_class = serie_builtin_class(x$data_series[[x$y]]),
+    sheetname = sheetname
+  )
+
+  str_series_ <- sapply(series, function(serie) {
+
+    n <- length(x$data_series[[x$x]])
+
+    if (n <= length(colour_list)) {
+      fill <- colour_list[[n]]
+    } else {
+      fill <- sample(colors(), size = n, replace = TRUE)
+    }
+
+    marker_str <- vapply(
+      fill,
+      get_sppr_xml,
+      stroke = "transparent",
+      NA_character_
+    )
+
+    for (ms in seq_along(marker_str)) {
+      marker_str[ms] <- paste0(
+        sprintf("<c:dPt><c:idx val=\"%s\"/><c:bubble3D val=\"0\"/>", ms - 1),
+        marker_str[ms],
+        "</c:dPt>"
+      )
+    }
+
+    label_settings <- x$label_settings
+    label_settings$labels_fp <- serie$labels_fp
+
+    if(!is.null(x$label_cols)){
+      label_pml <- to_pml(serie$label)
+    } else label_pml <- ""
+
+    paste0(
+      "<c:ser>",
+      sprintf("<c:idx val=\"%.0f\"/>", serie$idx),
+      sprintf("<c:order val=\"%.0f\"/>", serie$order),
+      "<c:tx>", to_pml(serie$tx), "</c:tx>",
+      paste0(marker_str, collapse = ""),
+      to_pml(label_settings, with_position = FALSE, show_label = !is.null(x$label_cols)),
+      "<c:cat>", to_pml(serie$x), "</c:cat>",
+      "<c:val>", to_pml(serie$y), "</c:val>",
+      label_pml,
+      "</c:ser>"
+    )
+  })
+
+  str_series_ <- paste(str_series_, collapse = "")
+
+  x_ax_id <- sprintf("<c:axId val=\"%s\"/>", id_x)
+  y_ax_id <- sprintf("<c:axId val=\"%s\"/>", id_y)
+
+  paste0(
+    "<c:pieChart>",
+    sprintf("<c:grouping val=\"%s\"/>", x$options$grouping),
+    sprintf("<c:varyColors val=\"%.0f\"/>", x$options$vary_colors),
+    str_series_,
+    to_pml(x$label_settings, with_position = FALSE, show_label = !is.null(x$label_cols)),
+    x_ax_id, y_ax_id,
+    "</c:pieChart>"
+  )
+}