flexsiteboard coverage - 94.05%

Files
Source

#' @importFrom stats setNames
post_knit <- function(metadata, input_file, runtime, ...) {
  preprocessed_file <- file.path(getwd(),
                                 sub("\\.Rmd$", ".knit.md", input_file))
  target_path <- #gsub("_files$", "_subpages",
                      dirname(knitr::opts_chunk$get("fig.path"))#)
  redirect_path <- #gsub("_files$", "_subpages",
                      basename(dirname(knitr::opts_chunk$get("fig.path")))#)
  dir.create(target_path, recursive = TRUE, showWarnings = FALSE)
  # file.copy(list.files(target_path), )
  oldwd <- setwd(target_path)
  on.exit(setwd(oldwd))
  target_path <- "."
  # on.exit({
  #   unlink(temp_path, recursive = TRUE, force = TRUE)
  # }, add = TRUE)
  htmlwidgets::JS("noop"
   ) # to suppress false positive NOTE about htmlwidgets not being used.
  preprocessed <- readLines(preprocessed_file)
  delimiters <- grep("^(---|\\.\\.\\.)\\s*$", preprocessed)
  if (length(delimiters) > 1) {
    front_matter <- preprocessed[(delimiters[[1]]+1):(delimiters[[2]]-1)]
    preprocessed <-
      preprocessed[(delimiters[[2]] + 1) : length(preprocessed)]
  } else {
    front_matter <- ""
  }
  front_matter <-
    gsub("flexdashboard::flex_dashboard",
         "flexsiteboard::no_output",
         front_matter,
         fixed = TRUE)
  front_matter <-
    gsub("flexsiteboard::flex_site_board",
         "flexdashboard::flex_dashboard",
         front_matter,
         fixed = TRUE)
  block_lines0 <-
    grep("^^#+ .*\\{(.+ )?data-navmenu=\"[^\"]+\"\\}", trimws(preprocessed))
  # Hint: pre block from after the front matter up to first headline
  #           -> copy to each split-file
  if (length(block_lines0)) {
    block0 <- preprocessed[seq_len(block_lines0[[1]] - 1)]
    preprocessed <- preprocessed[block_lines0[[1]]:length(preprocessed)]
    block_lines <-
      grep("^^#+ .*\\{(.+ )?data-navmenu=\"[^\"]+\"\\}", trimws(preprocessed))
    if (length(block_lines) > 1) {
      stopifnot(block_lines[[1]] == 1)
      block_lines_resolved <- mapply(`:`, 1 + (c(block_lines)),
                                     c(tail(block_lines - 1, -1),
                                       length(preprocessed)),
                                     SIMPLIFY = FALSE)

       html_headers <-
         pandoc_convert(text = preprocessed[block_lines],
                        from = "markdown",
                        to = "html5")

      ids <- tail(strsplit(
        html_headers,
        'id="',
        fixed = TRUE
      )[[1]], -1)
      ids <- gsub(
        "\".*$",
        "",
        ids
      )
      names(block_lines_resolved) <- ids
    }
    files <- lapply(block_lines_resolved,
                    function(l) preprocessed[l])

    files <- lapply(files, function(f) {
      p <- knitr::opts_chunk$get("fig.path")
      if (!startsWith(p, .Platform$file.sep)) {
        p2 <- # remove the first directory from the path
          intToUtf8(rev(utf8ToInt(dirname(intToUtf8(rev(utf8ToInt(p)))))))
        f <- gsub(p, p2, f, fixed = TRUE)
      }
      f
    })

    headlines <- setNames(nm = names(block_lines_resolved),
                          preprocessed[block_lines])

    html_dependencies <-
      knitr::knit_meta(clean = FALSE, class = "html_dependency")
    hash_index <- as.list(setNames(paste0(names(files),
                                          ".html#",
                                          ids), ids))
    for (f_i in seq_along(names(files))) {
      ### Function to plot histograms added by empirical cumulative distributions for subgroups\_0 {#res-s0_testx-functiontoplothistogramsaddedbyempiricalcumulativedistributionsforsubgroups_0}
      f <- names(files)[[f_i]]
      for (id in grep("\\{#.*?[}\\s]",
                      perl = TRUE,
                      value = TRUE,
                      files[[f_i]])) {
        id <- gsub("^.*\\{#(.*?)[}\\s].*$", # TODO: lines with two ids
                   "\\1",
                   perl = TRUE,
                   id)
        hash_index[[id]] <- paste0(f, '.html#', f, '#', id)
      }
    }

    hash_index <- lapply(hash_index,
                         jsonlite::unbox)
    for (f_i in seq_along(names(files))) {
      f <- names(files)[[f_i]]
      cat(
        c('---', front_matter, '---',
          '```{js echo=FALSE}','
              function goto_sub_anchor(flx, sub) {
                window.location.href = flx + ".html#" + flx;
                $(function() {
                  window.setTimeout(function() {
                    $([document.documentElement, document.body]).animate({
                      scrollTop: $("#" + sub).offset().top
                    }, 100);
                  }, 500)
                })
              }

              var hash_index = ',
          jsonlite::toJSON(hash_index)
          , ';
              $(document).ready(function() {
                $(\'#dashboard-container\').on(\'flexdashboard:layoutcomplete\', function() {
                  $(\'a[href!="#"][href^="#"]\').click(function() {
                    // TODO: Maybe, we should replace the hrefs of all these tags instead of doing this dynamically?
                    var alternative_target = hash_index[decodeURI(this.hash.replace("#", ""))]
                    if (alternative_target != undefined) {
                      location.replace(alternative_target);
                    }
                  });
                })
              })
              var verify_target = function() {
                var flx = undefined;
                var sub = undefined;
                if ((location.hash.match(/#/g) || []).length == 2) { // https://stackoverflow.com/a/4009768
                  flx = location.hash.match(/#(.*?)#(.*)/)[1]
                  sub = location.hash.match(/#(.*?)#(.*)/)[2]
                  goto_sub_anchor(flx, sub);
                  return;
                } else {
                  flx = location.hash.replace("#", "")
                  if (flx == "") {
                    flx = location.href.split("/").reverse()[0].replace(/\\.html#?$/i, "");
                    location.replace(flx + ".html#" + flx);
                    return;
                  }
                  var my_target = hash_index[decodeURI(flx)]
                  if (my_target != undefined) {
                    if (!location.href.endsWith("/" + my_target)) {

                      var m = my_target.match(/#(.*?)#(.*)/);

                      if (m != null && m.length > 2) {
                        flx = m[1];
                        sub = m[2];
                      } else if (my_target.match("#") != null) {
                        var m2 = my_target.match(/^(.*?)(?:\\.html)?#(.*?)$/);
                        flx = m2[1];
                        sub = m2[2];
                      } else {
                        flx = my_target;
                        sub = "";
                      }

                      if (!location.href.endsWith(flx + ".html#" + sub)) {
                        location.replace(flx + ".html#" + sub);
                        return;
                      }

                    }
                  }
                }
                window.setTimeout(verify_target, 100); // just to be on the safe side */
              }
              $(function() {
                window.setTimeout(verify_target, 100);
              });
              ',
          '```',
          '```{r include=TRUE}',
          'library(htmlwidgets)',
          # 'html_dependencies <- ',
          # deparse(html_dependencies),
          'knitr::knit_print(htmlwidgets::createWidget(name = "flex_site_board_sub_dashinit", x = "TEST!!", dependencies = html_dependencies, height = "0px", width = "0px"))',
          '```',
          block0,
          paste0(
            headlines[seq_len(f_i)]
          ),
          "\n",
          files[[f]],
          "\n",
          headlines[seq_len(length(files))[seq_len(length(files)) > f_i]]
        ),
        file = paste0(f, ".Rmd"),
        sep = "\n"
      )
      # dir.create(file.path(temp_path, target_path, "libs"), recursive = TRUE,
      #            showWarnings = FALSE)
      e <- new.env(parent = baseenv())
      e$html_dependencies <- html_dependencies
      message(sprintf("\nWrote file %s\n", rmarkdown::render(
        quiet = TRUE,
        input = paste0(f, ".Rmd"),
        envir = e,
        # output_options = list(
        #   lib_dir = file.path(target_path, "libs")
        # ),
        output_dir = target_path,
        output_file = paste0(f, ".html")
      )))
      try(unlink(paste0(f, ".Rmd")))
    }
    # cat(preprocessed, file = preprocessed_file, sep = "\n")
    front_matter_parsed_idx <- yaml::read_yaml(text = front_matter)
    # this does not work, seems to be already part of knit_meta here:
    # front_matter_parsed_idx$output$`flexdashboard::flex_dashboard`$includes =
    #   list(in_header = "redirect_header.html")
    knitr::knit_meta_add(list( # see https://rmarkdown.rstudio.com/docs/reference/output_format.html
      htmltools::htmlDependency(
        name = "flex-site-board-index-redirector",
        version = "0.0.1",
        src = c(file = system.file("",
                                   package = "flexsiteboard")),
        script =  "flexsiteboard.js",
        head =
          sprintf(
            '<meta http-equiv="refresh" content="0; url=%s.html"/>',
            file.path(redirect_path, names(files)[[1]])
          )
      )
    ))
    cat(
      '---',
      yaml::as.yaml(front_matter_parsed_idx),
      '---',
      sprintf('Go to [%s](%s.html)',
              front_matter_parsed_idx$title,
              file.path(redirect_path, names(files)[[1]])),
      htmltools::renderTags(htmltools::tags$script(htmltools::HTML(sprintf(
        '\n//<![CDATA[\nlocation.replace("%s.html");\n//]]>\n',
        file.path(redirect_path, names(files)[[1]])
      )), type = "text/javascript"))$html,
      file = preprocessed_file,
      sep = "\n"
    )
  }
  if (exists("orig", .props, mode = "function")) {
    get("orig", .props, mode = "function")(metadata, input_file, runtime, ...)
  } else {
    NULL
  }
}

#' Read a `Pandoc` File from some Supported Format
#'
#' @param file file to read
#' @param text string to use instead of file if set
#' @param from format of the file
#'
#' @return the `Pandoc` object
#' @export
pandoc_read <- function(file, text = NULL, from = pandoc_input_formats()) {
  from <- match.arg(from)
  if (is.null(text)) {
    args <- sprintf("-f %s -t json %s", shQuote(from), shQuote(normalizePath(file)))
  } else {
    args <- sprintf("-f %s -t json", shQuote(from))
  }
  pandoc <- system2(pandoc(), args, input = text, stdout=TRUE, stderr=TRUE)
  paste0(pandoc, collapse = "")
}

#' Flexible Dashboards Split in Sub-Pages
#'
#' @param ... see `flexdashbaord`
#'
#' Hint: Needs all global JavaScript code before the first header.
#'
#' @return a new format for `rmarkdown`
#' @export
#'
#' @importFrom utils tail
flex_site_board <- function(...) {

  .sc <- list(...)[["self_contained"]]

  if (length(.sc) != 1) {
    .sc <- TRUE
  }

  # keep_rmds, intermediates: quite fuzzy -- intermediates_generator is only
  # called, if an intermediates_dir has been given calling rmarkdown::render()
  fmt <- flexdashboard::flex_dashboard(...)

  if (.sc) {
    warning("argument 'self_contained = TRUE' by flex_site_board, disables flex_site_baord -- falling back to flex_dashboard")
    return(fmt)
  }


  if (rmarkdown::pandoc_version() >= "2.19") {
    # TODO: Pandoc 2.19 has deprecated the argument --self-contained. If you have installed Pandoc 2.19+, rmarkdown will use --embed-resources --standalone as recommended by Pandoc for output formats that use the option self_contained = TRUE (#2382).
    # https://rmarkdown.rstudio.com/docs/news/index.html
    if ("--embed-resources" %in% fmt$pandoc$args) {
      fmt$pandoc$args <-
        setdiff(fmt$pandoc$args, "--embed-resources")
    }
    if ("--standalone" %in% fmt$pandoc$args) {
      fmt$pandoc$args <-
        setdiff(fmt$pandoc$args, "--standalone")
    }
  } else {
    if ("--self-contained" %in% fmt$pandoc$args) {
      fmt$pandoc$args <-
        setdiff(fmt$pandoc$args, "--self-contained")
    }
  }

  knitenv <- knitr::knit_global()
  if (identical(knitenv, globalenv())) { # only, if not rendering a document
    knitenv <- new.env(parent = emptyenv()) # the object in the knit env is not needed
  }
  assign("is_flex_site_board", TRUE, envir = knitenv)
  # TODO: Detect, if both, dash and site are in the front-matter
  assign("orig", fmt$post_knit, .props)
  fmt$post_knit <- post_knit
  fmt$clean_supporting <- FALSE # why, oh why is this needed?! I cannot define intermediates?
  fmt
}

pandoc <- function() {
  if (!rmarkdown::pandoc_available()) {
    stop("Need pandoc (>= 2.4) - http://pandoc.org for conversion.") # nocov
  }
  rmarkdown::pandoc_exec()
}

..pandoc <- new.env(parent = emptyenv())

#' Give all Input Formats Supported by `Pandoc`
#'
#' @param use_cache don't call `Pandoc` again
#'
#' @return all supported `Pandoc` input formats
#' @export
pandoc_input_formats <- function(use_cache = TRUE) {
  if (!use_cache || !exists('pandoc_input_formats', envir = ..pandoc)) {
    assign('pandoc_input_formats',
           system2(pandoc(), "--list-input-formats",
                   stdout = TRUE, stderr = TRUE), envir = ..pandoc)
  }
  return(get('pandoc_input_formats', envir = ..pandoc))
}

#' Give all Output Formats Supported by `Pandoc`
#'
#' @param use_cache don't call `Pandoc` again
#'
#' @return all supported `Pandoc` output formats
#' @export
pandoc_output_formats <- function(use_cache = TRUE) {
  if (!use_cache || !exists('pandoc_output_formats', envir = ..pandoc)) {
    assign('pandoc_output_formats',
           system2(pandoc(), "--list-output-formats",
                   stdout = TRUE, stderr = TRUE), envir = ..pandoc)
  }
  return(get('pandoc_output_formats', envir = ..pandoc))
}

#' Write a `Pandoc` File
#'
#' @param pandoc internal `Pandoc` representation
#' @param to output format (supported by `Pandoc`)
#'
#' @return the converted text
#' @export
pandoc_write <- function(pandoc, to = pandoc_output_formats()) {
  to <- match.arg(to)
  args <- sprintf("-f json -t %s", shQuote(to))
  pandoc <- paste0(pandoc, collapse = "")
  paste(system2(pandoc(), args, input = pandoc, stdout=TRUE, stderr=TRUE), collapse = "\n")
}

#' Convert a `Pandoc` File
#'
#' @param file file to read
#' @param text string to use instead of file if set
#' @param from input format
#' @param to output format
#'
#' @return the converted text
#' @export
#'
#' @examples
#' if (rmarkdown::pandoc_available()) {
#'   x <- pandoc_convert(
#'       text = "\\section{Test}", from = "latex", to = "markdown")
#'   stopifnot(identical(x, "Test\n====") || identical(x, "# Test"))
#' }
pandoc_convert <- function(file, text = NULL, from = pandoc_input_formats(),
                           to = pandoc_output_formats()) {
  from <- match.arg(from)
  to <- match.arg(to)
  pandoc_write(pandoc_read(file = file, text = text, from = from), to = to)
}

1		#' Flexible Dashboards Split in Sub-Pages
2		#'
3		#' @param ... see `flexdashbaord`
4		#'
5		#' Hint: Needs all global JavaScript code before the first header.
6		#'
7		#' @return a new format for `rmarkdown`
8		#' @export
9		#'
10		#' @importFrom utils tail
11		flex_site_board <- function(...) {
12
13	2x	.sc <- list(...)[["self_contained"]]
14
15	2x	if (length(.sc) != 1) {
16	!	.sc <- TRUE
17		}
18
19		# keep_rmds, intermediates: quite fuzzy -- intermediates_generator is only
20		# called, if an intermediates_dir has been given calling rmarkdown::render()
21	2x	fmt <- flexdashboard::flex_dashboard(...)
22
23	2x	if (.sc) {
24	1x	warning("argument 'self_contained = TRUE' by flex_site_board, disables flex_site_baord -- falling back to flex_dashboard")
25	1x	return(fmt)
26		}
27
28
29	1x	if (rmarkdown::pandoc_version() >= "2.19") {
30		# TODO: Pandoc 2.19 has deprecated the argument --self-contained. If you have installed Pandoc 2.19+, rmarkdown will use --embed-resources --standalone as recommended by Pandoc for output formats that use the option self_contained = TRUE (#2382).
31		# https://rmarkdown.rstudio.com/docs/news/index.html
32	!	if ("--embed-resources" %in% fmt$pandoc$args) {
33	!	fmt$pandoc$args <-
34	!	setdiff(fmt$pandoc$args, "--embed-resources")
35		}
36	!	if ("--standalone" %in% fmt$pandoc$args) {
37	!	fmt$pandoc$args <-
38	!	setdiff(fmt$pandoc$args, "--standalone")
39		}
40		} else {
41	1x	if ("--self-contained" %in% fmt$pandoc$args) {
42	!	fmt$pandoc$args <-
43	!	setdiff(fmt$pandoc$args, "--self-contained")
44		}
45		}
46
47	1x	knitenv <- knitr::knit_global()
48	1x	if (identical(knitenv, globalenv())) { # only, if not rendering a document
49	1x	knitenv <- new.env(parent = emptyenv()) # the object in the knit env is not needed
50		}
51	1x	assign("is_flex_site_board", TRUE, envir = knitenv)
52		# TODO: Detect, if both, dash and site are in the front-matter
53	1x	assign("orig", fmt$post_knit, .props)
54	1x	fmt$post_knit <- post_knit
55	1x	fmt$clean_supporting <- FALSE # why, oh why is this needed?! I cannot define intermediates?
56	1x	fmt
57		}

1		pandoc <- function() {
2	8x	if (!rmarkdown::pandoc_available()) {
3		stop("Need pandoc (>= 2.4) - http://pandoc.org for conversion.") # nocov
4		}
5	8x	rmarkdown::pandoc_exec()
6		}
7
8		..pandoc <- new.env(parent = emptyenv())
9
10		#' Give all Input Formats Supported by `Pandoc`
11		#'
12		#' @param use_cache don't call `Pandoc` again
13		#'
14		#' @return all supported `Pandoc` input formats
15		#' @export
16		pandoc_input_formats <- function(use_cache = TRUE) {
17	5x	if (!use_cache \|\| !exists('pandoc_input_formats', envir = ..pandoc)) {
18	1x	assign('pandoc_input_formats',
19	1x	system2(pandoc(), "--list-input-formats",
20	1x	stdout = TRUE, stderr = TRUE), envir = ..pandoc)
21		}
22	5x	return(get('pandoc_input_formats', envir = ..pandoc))
23		}
24
25		#' Give all Output Formats Supported by `Pandoc`
26		#'
27		#' @param use_cache don't call `Pandoc` again
28		#'
29		#' @return all supported `Pandoc` output formats
30		#' @export
31		pandoc_output_formats <- function(use_cache = TRUE) {
32	5x	if (!use_cache \|\| !exists('pandoc_output_formats', envir = ..pandoc)) {
33	1x	assign('pandoc_output_formats',
34	1x	system2(pandoc(), "--list-output-formats",
35	1x	stdout = TRUE, stderr = TRUE), envir = ..pandoc)
36		}
37	5x	return(get('pandoc_output_formats', envir = ..pandoc))
38		}

1		#' @importFrom stats setNames
2		post_knit <- function(metadata, input_file, runtime, ...) {
3	1x	preprocessed_file <- file.path(getwd(),
4	1x	sub("\\.Rmd$", ".knit.md", input_file))
5	1x	target_path <- #gsub("_files$", "_subpages",
6	1x	dirname(knitr::opts_chunk$get("fig.path"))#)
7	1x	redirect_path <- #gsub("_files$", "_subpages",
8	1x	basename(dirname(knitr::opts_chunk$get("fig.path")))#)
9	1x	dir.create(target_path, recursive = TRUE, showWarnings = FALSE)
10		# file.copy(list.files(target_path), )
11	1x	oldwd <- setwd(target_path)
12	1x	on.exit(setwd(oldwd))
13	1x	target_path <- "."
14		# on.exit({
15		# unlink(temp_path, recursive = TRUE, force = TRUE)
16		# }, add = TRUE)
17	1x	htmlwidgets::JS("noop"
18	1x	) # to suppress false positive NOTE about htmlwidgets not being used.
19	1x	preprocessed <- readLines(preprocessed_file)
20	1x	delimiters <- grep("^(---\|\\.\\.\\.)\\s*$", preprocessed)
21	1x	if (length(delimiters) > 1) {
22	1x	front_matter <- preprocessed[(delimiters[[1]]+1):(delimiters[[2]]-1)]
23	1x	preprocessed <-
24	1x	preprocessed[(delimiters[[2]] + 1) : length(preprocessed)]
25		} else {
26	!	front_matter <- ""
27		}
28	1x	front_matter <-
29	1x	gsub("flexdashboard::flex_dashboard",
30	1x	"flexsiteboard::no_output",
31	1x	front_matter,
32	1x	fixed = TRUE)
33	1x	front_matter <-
34	1x	gsub("flexsiteboard::flex_site_board",
35	1x	"flexdashboard::flex_dashboard",
36	1x	front_matter,
37	1x	fixed = TRUE)
38	1x	block_lines0 <-
39	1x	grep("^^#+ .*\\{(.+ )?data-navmenu=\"[^\"]+\"\\}", trimws(preprocessed))
40		# Hint: pre block from after the front matter up to first headline
41		# -> copy to each split-file
42	1x	if (length(block_lines0)) {
43	1x	block0 <- preprocessed[seq_len(block_lines0[[1]] - 1)]
44	1x	preprocessed <- preprocessed[block_lines0[[1]]:length(preprocessed)]
45	1x	block_lines <-
46	1x	grep("^^#+ .*\\{(.+ )?data-navmenu=\"[^\"]+\"\\}", trimws(preprocessed))
47	1x	if (length(block_lines) > 1) {
48	1x	stopifnot(block_lines[[1]] == 1)
49	1x	block_lines_resolved <- mapply(`:`, 1 + (c(block_lines)),
50	1x	c(tail(block_lines - 1, -1),
51	1x	length(preprocessed)),
52	1x	SIMPLIFY = FALSE)
53
54	1x	html_headers <-
55	1x	pandoc_convert(text = preprocessed[block_lines],
56	1x	from = "markdown",
57	1x	to = "html5")
58
59	1x	ids <- tail(strsplit(
60	1x	html_headers,
61	1x	'id="',
62	1x	fixed = TRUE
63	1x	)[[1]], -1)
64	1x	ids <- gsub(
65		"\".*$",
66		"",
67	1x	ids
68		)
69	1x	names(block_lines_resolved) <- ids
70		}
71	1x	files <- lapply(block_lines_resolved,
72	1x	function(l) preprocessed[l])
73
74	1x	files <- lapply(files, function(f) {
75	3x	p <- knitr::opts_chunk$get("fig.path")
76	3x	if (!startsWith(p, .Platform$file.sep)) {
77	3x	p2 <- # remove the first directory from the path
78	3x	intToUtf8(rev(utf8ToInt(dirname(intToUtf8(rev(utf8ToInt(p)))))))
79	3x	f <- gsub(p, p2, f, fixed = TRUE)
80		}
81	3x	f
82		})
83
84	1x	headlines <- setNames(nm = names(block_lines_resolved),
85	1x	preprocessed[block_lines])
86
87	1x	html_dependencies <-
88	1x	knitr::knit_meta(clean = FALSE, class = "html_dependency")
89	1x	hash_index <- as.list(setNames(paste0(names(files),
90	1x	".html#",
91	1x	ids), ids))
92	1x	for (f_i in seq_along(names(files))) {
93		### Function to plot histograms added by empirical cumulative distributions for subgroups\_0 {#res-s0_testx-functiontoplothistogramsaddedbyempiricalcumulativedistributionsforsubgroups_0}
94	3x	f <- names(files)[[f_i]]
95	3x	for (id in grep("\\{#.*?[}\\s]",
96	3x	perl = TRUE,
97	3x	value = TRUE,
98	3x	files[[f_i]])) {
99	!	id <- gsub("^.\\{#(.?)[}\\s].*$", # TODO: lines with two ids
100	!	"\\1",
101	!	perl = TRUE,
102	!	id)
103	!	hash_index[[id]] <- paste0(f, '.html#', f, '#', id)
104		}
105		}
106
107	1x	hash_index <- lapply(hash_index,
108	1x	jsonlite::unbox)
109	1x	for (f_i in seq_along(names(files))) {
110	3x	f <- names(files)[[f_i]]
111	3x	cat(
112	3x	c('---', front_matter, '---',
113	3x	'```{js echo=FALSE}','
114	3x	function goto_sub_anchor(flx, sub) {
115	3x	window.location.href = flx + ".html#" + flx;
116	3x	$(function() {
117	3x	window.setTimeout(function() {
118	3x	$([document.documentElement, document.body]).animate({
119	3x	scrollTop: $("#" + sub).offset().top
120	3x	}, 100);
121	3x	}, 500)
122		})
123		}
124
125	3x	var hash_index = ',
126	3x	jsonlite::toJSON(hash_index)
127		, ';
128	3x	$(document).ready(function() {
129	3x	$(\'#dashboard-container\').on(\'flexdashboard:layoutcomplete\', function() {
130	3x	$(\'a[href!="#"][href^="#"]\').click(function() {
131	3x	// TODO: Maybe, we should replace the hrefs of all these tags instead of doing this dynamically?
132	3x	var alternative_target = hash_index[decodeURI(this.hash.replace("#", ""))]
133	3x	if (alternative_target != undefined) {
134	3x	location.replace(alternative_target);
135		}
136		});
137		})
138		})
139	3x	var verify_target = function() {
140	3x	var flx = undefined;
141	3x	var sub = undefined;
142	3x	if ((location.hash.match(/#/g) \|\| []).length == 2) { // https://stackoverflow.com/a/4009768
143	3x	flx = location.hash.match(/#(.?)#(.)/)[1]
144	3x	sub = location.hash.match(/#(.?)#(.)/)[2]
145	3x	goto_sub_anchor(flx, sub);
146	3x	return;
147		} else {
148	3x	flx = location.hash.replace("#", "")
149	3x	if (flx == "") {
150	3x	flx = location.href.split("/").reverse()[0].replace(/\\.html#?$/i, "");
151	3x	location.replace(flx + ".html#" + flx);
152	3x	return;
153		}
154	3x	var my_target = hash_index[decodeURI(flx)]
155	3x	if (my_target != undefined) {
156	3x	if (!location.href.endsWith("/" + my_target)) {
157
158	3x	var m = my_target.match(/#(.?)#(.)/);
159
160	3x	if (m != null && m.length > 2) {
161	3x	flx = m[1];
162	3x	sub = m[2];
163	3x	} else if (my_target.match("#") != null) {
164	3x	var m2 = my_target.match(/^(.?)(?:\\.html)?#(.?)$/);
165	3x	flx = m2[1];
166	3x	sub = m2[2];
167		} else {
168	3x	flx = my_target;
169	3x	sub = "";
170		}
171
172	3x	if (!location.href.endsWith(flx + ".html#" + sub)) {
173	3x	location.replace(flx + ".html#" + sub);
174	3x	return;
175		}
176
177		}
178		}
179		}
180	3x	window.setTimeout(verify_target, 100); // just to be on the safe side */
181		}
182	3x	$(function() {
183	3x	window.setTimeout(verify_target, 100);
184		});
185		',
186		'```',
187	3x	'```{r include=TRUE}',
188	3x	'library(htmlwidgets)',
189		# 'html_dependencies <- ',
190		# deparse(html_dependencies),
191	3x	'knitr::knit_print(htmlwidgets::createWidget(name = "flex_site_board_sub_dashinit", x = "TEST!!", dependencies = html_dependencies, height = "0px", width = "0px"))',
192		'```',
193	3x	block0,
194	3x	paste0(
195	3x	headlines[seq_len(f_i)]
196		),
197	3x	"\n",
198	3x	files[[f]],
199	3x	"\n",
200	3x	headlines[seq_len(length(files))[seq_len(length(files)) > f_i]]
201		),
202	3x	file = paste0(f, ".Rmd"),
203	3x	sep = "\n"
204		)
205		# dir.create(file.path(temp_path, target_path, "libs"), recursive = TRUE,
206		# showWarnings = FALSE)
207	3x	e <- new.env(parent = baseenv())
208	3x	e$html_dependencies <- html_dependencies
209	3x	message(sprintf("\nWrote file %s\n", rmarkdown::render(
210	3x	quiet = TRUE,
211	3x	input = paste0(f, ".Rmd"),
212	3x	envir = e,
213		# output_options = list(
214		# lib_dir = file.path(target_path, "libs")
215		# ),
216	3x	output_dir = target_path,
217	3x	output_file = paste0(f, ".html")
218		)))
219	3x	try(unlink(paste0(f, ".Rmd")))
220		}
221		# cat(preprocessed, file = preprocessed_file, sep = "\n")
222	1x	front_matter_parsed_idx <- yaml::read_yaml(text = front_matter)
223		# this does not work, seems to be already part of knit_meta here:
224		# front_matter_parsed_idx$output$`flexdashboard::flex_dashboard`$includes =
225		# list(in_header = "redirect_header.html")
226	1x	knitr::knit_meta_add(list( # see https://rmarkdown.rstudio.com/docs/reference/output_format.html
227	1x	htmltools::htmlDependency(
228	1x	name = "flex-site-board-index-redirector",
229	1x	version = "0.0.1",
230	1x	src = c(file = system.file("",
231	1x	package = "flexsiteboard")),
232	1x	script = "flexsiteboard.js",
233	1x	head =
234	1x	sprintf(
235	1x	'<meta http-equiv="refresh" content="0; url=%s.html"/>',
236	1x	file.path(redirect_path, names(files)[[1]])
237		)
238		)
239		))
240	1x	cat(
241		'---',
242	1x	yaml::as.yaml(front_matter_parsed_idx),
243		'---',
244	1x	sprintf('Go to [%s](%s.html)',
245	1x	front_matter_parsed_idx$title,
246	1x	file.path(redirect_path, names(files)[[1]])),
247	1x	htmltools::renderTags(htmltools::tags$script(htmltools::HTML(sprintf(
248	1x	'\n//<![CDATA[\nlocation.replace("%s.html");\n//]]>\n',
249	1x	file.path(redirect_path, names(files)[[1]])
250	1x	)), type = "text/javascript"))$html,
251	1x	file = preprocessed_file,
252	1x	sep = "\n"
253		)
254		}
255	1x	if (exists("orig", .props, mode = "function")) {
256	1x	get("orig", .props, mode = "function")(metadata, input_file, runtime, ...)
257		} else {
258	!	NULL
259		}
260		}

1		#' Read a `Pandoc` File from some Supported Format
2		#'
3		#' @param file file to read
4		#' @param text string to use instead of file if set
5		#' @param from format of the file
6		#'
7		#' @return the `Pandoc` object
8		#' @export
9		pandoc_read <- function(file, text = NULL, from = pandoc_input_formats()) {
10	3x	from <- match.arg(from)
11	3x	if (is.null(text)) {
12	1x	args <- sprintf("-f %s -t json %s", shQuote(from), shQuote(normalizePath(file)))
13		} else {
14	2x	args <- sprintf("-f %s -t json", shQuote(from))
15		}
16	3x	pandoc <- system2(pandoc(), args, input = text, stdout=TRUE, stderr=TRUE)
17	3x	paste0(pandoc, collapse = "")
18		}

1		#' Write a `Pandoc` File
2		#'
3		#' @param pandoc internal `Pandoc` representation
4		#' @param to output format (supported by `Pandoc`)
5		#'
6		#' @return the converted text
7		#' @export
8		pandoc_write <- function(pandoc, to = pandoc_output_formats()) {
9	3x	to <- match.arg(to)
10	3x	args <- sprintf("-f json -t %s", shQuote(to))
11	3x	pandoc <- paste0(pandoc, collapse = "")
12	3x	paste(system2(pandoc(), args, input = pandoc, stdout=TRUE, stderr=TRUE), collapse = "\n")
13		}

1		#' Convert a `Pandoc` File
2		#'
3		#' @param file file to read
4		#' @param text string to use instead of file if set
5		#' @param from input format
6		#' @param to output format
7		#'
8		#' @return the converted text
9		#' @export
10		#'
11		#' @examples
12		#' if (rmarkdown::pandoc_available()) {
13		#' x <- pandoc_convert(
14		#' text = "\\section{Test}", from = "latex", to = "markdown")
15		#' stopifnot(identical(x, "Test\n====") \|\| identical(x, "# Test"))
16		#' }
17		pandoc_convert <- function(file, text = NULL, from = pandoc_input_formats(),
18		to = pandoc_output_formats()) {
19	2x	from <- match.arg(from)
20	2x	to <- match.arg(to)
21	2x	pandoc_write(pandoc_read(file = file, text = text, from = from), to = to)
22		}