Nothing
# Global options #### knitr::opts_chunk$set(echo = FALSE, message = FALSE, results = "asis", error = FALSE, warning = FALSE, dpi = 300L, st_options = "rmarkdown") knitr::opts_chunk$set(smart = FALSE) # Pander #### pander::panderOptions("knitr.auto.asis", FALSE) pander::panderOptions("table.alignment.rownames", "left") pander::panderOptions("table.alignment.default", "left") pander::panderOptions("table.style", "multiline") pander::panderOptions("keep.line.breaks", TRUE) pander::panderOptions("table.split.table", Inf)
data <- params$combined_codebook
split_var_text <- function(text, limit = 30L) { #' Split variable name if it is too long at the underscores #' Is needed because sometimes the variable names are too long if (nchar(text) <= limit) { return(text) } # Locate all positions of `_` underscore_positions <- gregexpr("_", text)[[1L]] # Find the last underscore position before the limit split_position <- max(underscore_positions[underscore_positions < limit]) # Split the text at the found position and insert a line break if (split_position > 0L) { text <- paste0( substr(text, 1L, split_position), "\\\n", substr(text, split_position + 1L, nchar(text)) ) } return(text) } panderwithsplit <- function(table, splitvarname) { #' Run split_var_text at set longest varname if splitvarname == TRUE #' Is needed because sometimes the variable names are too long table_copy <- table spaces <- 0L padding <- 4L if (splitvarname) { # Split text and set default split.cells table_copy$Variable <- unlist(lapply(table_copy$Variable, split_var_text)) maxvarname <- 30L - padding # Keep default } else { # Length of the longest variable name used to set split.cells # (It is usually dynamic by default, however, # not if there are underscores # in the variable names) maxvarname <- nchar(max(table_copy$Variable)) if (maxvarname < 30L) { spaces <- 30L - maxvarname } } out <- list() out$table <- table_copy # Compute cell width n_uppercase <- sum(sapply(gregexpr("[A-Z]", maxvarname)[[1L]], function(x) x > 0L)) n_lowercase <- maxvarname - n_uppercase out$col1_length <- (n_lowercase + n_uppercase * 1.142857 + # n_uppercases are wider than lowercases spaces * 0.98 + # spaces are smaller than letters padding) out$col1_length <- round(out$col1_length) out$col2_length <- 90L - out$col1_length return(out) } list_to_string <- function(x) { # If x is a vector or list, convert it to a string representation if (is.vector(x)) { listvec <- "ctest(" if (is.list(x)) { listvec <- "list(" } # Use lapply to recursively apply the function to any nested vectors elements <- lapply(x, function(e) { if (is.vector(e) && !is.atomic(e)) { # If element is a vector, call the function recursively return(list_to_string(e)) } else { # Otherwise, just return the element as a string return(deparse(e)) } }) # Create a string return(paste0(listvec, paste(elements, collapse = ", "), ")")) } return(deparse(x)) } makechunks <- function(variable, varval_i, chunk_size = 4L) { # Each chunk should only be 4 rows long chunks <- list() cj <- 1L # Iterate over the input and assign to chunks for (i in seq_along(varval_i)) { varval_sub <- paste(varval_i[[i]], collapse = ", ") if (i == 1L) { chunks[[cj]] <- varval_sub } else if ((i - 1L) %% chunk_size == 0L) { # Start a new chunk cj <- cj + 1L chunks[[cj]] <- varval_sub } else if ((i - 1L) %% chunk_size != 0L) { # Append to the current chunk chunks[[cj]] <- paste(chunks[[cj]], varval_sub, sep = "\\\n") } } # Create output table variables and values table_variables <- rep("", length(chunks)) table_variables[1L] <- variable # Assign the variable name to the first chunk table_values <- chunks # The chunks are the valuesf # Return the list of variables and values return(list(var = table_variables, val = table_values)) }
get_app <- function(params, data, folder) { #' Print app heading and app documentation text output <- paste0("\n\n# App: ", folder, "\n\n") if (!is.null(params$app_doc) && params$app_doc && !is.null(data[[folder]]$doc) && data[[folder]]$doc != "") { # Replace \\ with \n data[[folder]]$doc <- gsub("\\\\", "\n\n", data[[folder]]$doc) output <- paste(output, "\n\n Documentation: ", data[[folder]]$doc, "\n\n") } return(output) }
values_group_player <- function(subdata, variable) { # Values #### varval <- "" # Doc if ("doc" %in% names(subdata[[variable]]) && subdata[[variable]][["doc"]] != "" ) { varval <- paste0(varval, " Doc: ", subdata[[variable]][["doc"]], "\\\n") } # Field type varval <- paste0(varval, " Field type: ", subdata[[variable]][["field"]], "\\\n") # Widget if ("widget" %in% names(subdata[[variable]])) { varval <- paste0(varval, " Widget: ", subdata[[variable]]$widget, "\\\n") } # Label if ("label" %in% names(subdata[[variable]]) && subdata[[variable]][["label"]] != "") { varval <- paste0(varval, " Label: ", subdata[[variable]][["label"]], "\\\n") } # Verbose name if ("verbose_name" %in% names(subdata[[variable]]) && subdata[[variable]][["verbose_name"]] != "") { varval <- paste0(varval, " Verbose_name: ", subdata[[variable]][["verbose_name"]], "\\\n") } # Choices if ("choices" %in% names(subdata[[variable]])) { if ("key" %in% names(subdata[[variable]][["choices"]])) { varval <- paste0(varval, " Options:\\\n") varval <- paste0(varval, paste(" ", subdata[[variable]][["choices"]][["key"]], "=", subdata[[variable]][["choices"]][["value"]], collapse = "\\\n"), "\\\n") } else if ("value" %in% names(subdata[[variable]][["choices"]])) { varval <- paste0(varval, " Options:\\\n") varval <- paste0(varval, paste( sapply( unlist(subdata[[variable]][["choices"]][["value"]]), function(x) paste0(" ", x)), collapse = "\\\n"), "\\\n") } else { varval <- paste0(varval, " Options:\\\n") varval <- paste0(varval, paste( sapply( unlist(subdata[[variable]][["choices"]]), function(x) paste0(" ", x)), collapse = "\\\n"), "\\\n") } } # Max length of variable name if ("max_length" %in% names(subdata[[variable]])) { varval <- paste0(varval, " Maximal length: ", subdata[[variable]]$max_length, "\\\n") } # Min value if ("min" %in% names(subdata[[variable]])) { varval <- paste0(varval, " Minimum: ", subdata[[variable]]$min, "\\\n") } # Max value if ("max" %in% names(subdata[[variable]])) { varval <- paste0(varval, " Maximum: ", subdata[[variable]]$max, "\\\n") } # Initial if (params$initial && "initial" %in% names(subdata[[variable]])) { varval <- paste0(varval, " Initial: ", subdata[[variable]]$initial, "\\\n") } # Remove last carriage return #### sub("\\\\\\n$", "", varval) # Return #### return(varval) }
values_constants <- function(subdata, class, folder) { # Initialize lists table_variables <- vector("character", length = 0L) table_values <- vector("character", length = 0L) # Loop through variable names for (variable in names(subdata)) { # Error messages (TODO do I even need them?) #### if (is.null(subdata)) { stop("Data of class ", class, " in app ", folder, " is not there!") } if (!is.list(subdata)) { stop("Data of class ", class, " in app ", folder, " is not a list!") } if (is.null(variable)) { stop("Variable ", variable, " in class ", class, " in app ", folder, " is not there!") } # Make table values #### if (length(subdata[[variable]]) == 1L) { table_variables <- c(table_variables, variable) table_values <- c(table_values, subdata[[variable]][[1L]]) } else if (length(subdata[[variable]]) > 1L) { varval_i <- "" if (params$sep_list == "newline") { if (all(lengths(subdata[[variable]]) == 1L)) { # If each sublist only contains one element treat it as vector varval_i <- paste(subdata[[variable]], collapse = ", ") } else { if (params$pdf) { chunkparts <- makechunks(variable = variable, varval_i = subdata[[variable]]) variable <- unlist(chunkparts$var) varval_i <- unlist(chunkparts$val) } else { # Iterate over each element in the sublist for (i in seq_along(subdata[[variable]])) { x <- unlist(subdata[[variable]][i]) varval_sub <- paste(x, collapse = ", ") varval_i <- ifelse(varval_i == "", varval_sub, paste(varval_i, varval_sub, sep = "\\\n")) } } } table_variables <- c(table_variables, variable) table_values <- c(table_values, varval_i) } else if (params$sep_list == "vector") { table_variables <- c(table_variables, variable) table_values <- c(table_values, list_to_string(subdata[[variable]])) } } } # Construct the final data frame table <- data.frame(Variable = table_variables, Value = table_values, stringsAsFactors = FALSE) return(table) }
data$settings <- NULL for (folder in names(data)) { if (folder != "settings" && folder != "user_settings") { # App documentation and header cat(get_app(params, data, folder)) # Variable information for (class in names(data[[folder]])) { # Get all the variables of a class and their information subdata <- data[[folder]][[class]] if (class != "Constants" && class != "doc" && !(class == "Subsession" && !include_subs) ) { cat("\n\n## Class: ", class, "\n\n") if (length(subdata) != 0L) { # If pass if (is.null(names(subdata))) { cat("\n\nNo model fields except the built-in ones\n") } else { # For variables table_var <- data.frame(Variable = names(subdata)) table_var$Value <- sapply(table_var$Variable, FUN = function(x) values_group_player(subdata, x)) # Remove last \n table_var[nrow(table_var), ] <- sub(pattern = "\\\\\\n$", replacement = "", x = table_var[nrow(table_var), ]) # Split variable name xx <- panderwithsplit(table_var, params$splitvarname ) # Show app table pander::pander(xx$table, split.cells = c(xx$col1_length, xx$col2_length)) cat("\n\n") } } else { cat("\n\nNo model fields except the built-in ones\n") } } else if (class == "Constants" && params$include_cons) { cat("\n\n## Class: ", class, "\n\n") if (length(subdata) != 0L) { # If pass if (is.null(names(subdata))) { # This will never occur cat("\n\nNo Constants variables\n\n") } else { # Make table table_var <- values_constants(subdata = subdata, class = class, folder = folder) # Split variable name xx <- panderwithsplit(table_var, params$splitvarname ) # Show Constants table pander::pander(xx$table, split.cells = c(xx$col1_length, xx$col2_length)) cat("\n\n") } } } } } }
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.