`r params$title`"

# 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("&nbsp;&nbsp;&nbsp;",
                          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("&nbsp;&nbsp;&nbsp;", x)),
                          collapse = "\\\n"),
                        "\\\n")

        } else {
          varval <- paste0(varval, "  Options:\\\n")
          varval <- paste0(varval,
                        paste(
                          sapply(
                            unlist(subdata[[variable]][["choices"]]),
                            function(x) paste0("&nbsp;&nbsp;&nbsp;", 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")

          }
        }
      }
    }
  }
}


Try the gmoTree package in your browser

Any scripts or data that you put into this service are public.

gmoTree documentation built on April 3, 2025, 10:26 p.m.