Nothing
# To allow some dot notation here and there
globalVariables(c("."))
# Naming Conventions ----
# extract_xxxx extracts information from the model
# get_xxxx retrieves information from the theme (styles, etc.)
# format_xxx applies more/less smart formatting to content
# dot_xxxx generates dot code
# Main exported methods ----
#' Plot various SEMinR models
#'
#' With the help of the \code{DiagrammeR} package this dot graph can then be plotted in
#' various in RMarkdown, shiny, and other contexts.
#' Depending on the type of model, different parameters can be used.
#' Please check the \code{\link{dot_graph}} function for additional parameters.
#'
#' @param x The model description
#' @param title An optional title for the plot
#' @param theme Theme created with \code{\link{seminr_theme_create}}.
#' @param ... Please check the \code{\link{dot_graph}} for the additional parameters
#'
#' @return Returns the plot.
#' @export
plot.seminr_model <- function(x,
title = "",
theme = NULL,
...) {
query_install("DiagrammeR", "Alternatively use the dot_graph() function to create a dot graph.")
model <- x
# lavaan models
if (inherits(model, "cfa_model")) {
message("Plotting of lavaan models using semPlot.")
dot_graph.cfa_model(model, ...)
return()
}
if (inherits(model, "cbsem_model")) {
message("Plotting of lavaan models using semPlot.")
dot_graph.cbsem_model(model, ...)
return()
}
if (inherits(title, "seminr_theme")) {
warning(paste0("You have supplied a theme in the title parameter. ",
"Please use named parameters to use a specific theme: ",
"plot(model, theme = thm).")
)
}
# actual plotting
if(requireNamespace("DiagrammeR", quietly = TRUE)){
res <- DiagrammeR::grViz(dot_graph(model, title, theme, ...))
set_last_seminr_plot(res)
return(res)
} else {
return(NULL)
}
}
query_install <- function(pkg_name = "DiagrammeR", failure_msg=""){
if (!requireNamespace(pkg_name, quietly = TRUE)) {
if (interactive()) {
x <- readline(paste0(
"----------------------------------------------------------------------\n",
"This function requires the ", pkg_name, " package.\n",
"You can install it by calling: install.packages(\"", pkg_name, "\")\n",
"Do you want to install ", pkg_name, " right now (Y/n)? "
))
if (x == "Y") {
utils::install.packages(pkg_name)
} else {
stop(
paste0("You have selected no. Please use a capital Y to agree with installing ",pkg_name, " on your machine.\n",
failure_msg
)
)
}
}
}
}
#' Saves a SEMinR model plot to file
#'
#' Saves a SEMinR model plot to a graphical file. Default output is RPlots.pdf.
#'
#' @param filename The name of the file output (can be png, pdf, webp, ps, or svg.)
#' @param plot A plot that is created from the \code{\link{plot}} function. By default it uses the last plot created.
#' @param width An optional parameter for width in pixels.
#' @param height An optional parameter for height in pixels.
#'
#' @return Does not return a value
#' @export
#'
#' @examples
#' mobi <- mobi
#'
#' # seminr syntax for creating measurement model
#' mobi_mm <- constructs(
#' reflective("Image", multi_items("IMAG", 1:5)),
#' reflective("Expectation", multi_items("CUEX", 1:3)),
#' reflective("Quality", multi_items("PERQ", 1:7)),
#' reflective("Value", multi_items("PERV", 1:2)),
#' reflective("Satisfaction", multi_items("CUSA", 1:3)),
#' reflective("Complaints", single_item("CUSCO")),
#' reflective("Loyalty", multi_items("CUSL", 1:3))
#' )
#' # seminr syntax for creating structural model
#' mobi_sm <- relationships(
#' paths(from = "Image", to = c("Expectation", "Satisfaction", "Loyalty")),
#' paths(from = "Expectation", to = c("Quality", "Value", "Satisfaction")),
#' paths(from = "Quality", to = c("Value", "Satisfaction")),
#' paths(from = "Value", to = c("Satisfaction")),
#' paths(from = "Satisfaction", to = c("Complaints", "Loyalty")),
#' paths(from = "Complaints", to = "Loyalty")
#' )
#'
#' # estimate the model
#' mobi_pls <- estimate_pls(data = mobi,
#' measurement_model = mobi_mm,
#' structural_model = mobi_sm)
#' \dontrun{
#' # generate the plot
#' plot(mobi_pls)
#' # save to file
#' save_plot("myplot.pdf")
#' }
#'
save_plot <- function(filename = "RPlot.pdf", plot = last_seminr_plot(), width = NULL, height = NULL){
query_install("DiagrammeRsvg")
query_install("rsvg")
# prevent failure quietly
if(!requireNamespace("DiagrammeRsvg", quietly = TRUE)){
return(NULL)
}
if(!requireNamespace("rsvg", quietly = TRUE)){
return(NULL)
}
if (is.null(plot)) {
stop("No compatible plot was created.")
}
# generate svg string
svg <- charToRaw( DiagrammeRsvg::export_svg(plot) )
file_extension <- tolower(tools::file_ext(filename))
result = switch(
file_extension,
"pdf" = {rsvg::rsvg_pdf(svg, filename, width = width, height = height)},
"png" = {rsvg::rsvg_png(svg, filename, width = width, height = height)},
"ps" = {rsvg::rsvg_ps(svg, filename, width = width, height = height)},
"svg" = {rsvg::rsvg_svg(svg, filename, width = width, height = height)},
"webp" = {
query_install("webp")
rsvg::rsvg_webp(svg, filename, width = width, height = height)
},
"raw" = {rsvg::rsvg_raw(svg, filename, width = width, height = height)},
# else
{message(paste0("Unsuported file type: '", file_extension, "'. Please use either png, pdf, ps, webp, or svg"))}
)
}
# ___________________ ----
# DOT GRAPH (main function)----
#' Generate a dot graph from various SEMinR models
#'
#' With the help of the \code{DiagrammeR} package this dot graph can then be plotted in
#' various in RMarkdown, shiny, and other contexts.
#' Depending on the type of model, different parameters can be used.
#'
#' Current limitations:
#' - Only plots PLS Models
#' - no higher order constructs
#'
#' @param model The model description
#' @param title An optional title for the plot
#' @param theme Theme created with \code{\link{seminr_theme_create}}.
#' @param ... Additional parameters
#'
#' @return The path model as a formatted string in dot language.
#' @export
#'
#' @examples
#' mobi <- mobi
#'
#' #seminr syntax for creating measurement model
#' mobi_mm <- constructs(
#' reflective("Image", multi_items("IMAG", 1:5)),
#' reflective("Expectation", multi_items("CUEX", 1:3)),
#' reflective("Quality", multi_items("PERQ", 1:7)),
#' reflective("Value", multi_items("PERV", 1:2)),
#' reflective("Satisfaction", multi_items("CUSA", 1:3)),
#' reflective("Complaints", single_item("CUSCO")),
#' reflective("Loyalty", multi_items("CUSL", 1:3))
#' )
#' #seminr syntax for creating structural model
#' mobi_sm <- relationships(
#' paths(from = "Image", to = c("Expectation", "Satisfaction", "Loyalty")),
#' paths(from = "Expectation", to = c("Quality", "Value", "Satisfaction")),
#' paths(from = "Quality", to = c("Value", "Satisfaction")),
#' paths(from = "Value", to = c("Satisfaction")),
#' paths(from = "Satisfaction", to = c("Complaints", "Loyalty")),
#' paths(from = "Complaints", to = "Loyalty")
#' )
#'
#' mobi_pls <- estimate_pls(data = mobi,
#' measurement_model = mobi_mm,
#' structural_model = mobi_sm)
#'
#' # adapt nboot for better results
#' mobi_boot <- bootstrap_model(mobi_pls, nboot = 20, cores = 1)
#' # generate dot-Notation
#' res <- dot_graph(mobi_pls, title = "PLS-Model plot")
#'
#' \dontrun{
#' DiagrammeR::grViz(res)}
#'
#' # generate dot-Notation
#' res <- dot_graph(mobi_boot, title = "Bootstrapped PLS-Model plot")
#'
#' \dontrun{
#' DiagrammeR::grViz(res)}
#'
dot_graph <- function(model,
title = "",
theme = NULL,
...) {
UseMethod("dot_graph")
}
#' Plotting of confirmatory factor analysis models using semPLOT
#'
#' For a full description of parameters for lavaan models see semPaths method in the semPlot package.
#'
#' @rdname dot_graph
#' @param model the CFA model
#' @param title Unused
#' @param theme Unused
#' @param what The metric to use for edges ("path", "est", "std", "eq", "col")
#' @param whatLabels The metric to use for edge labels
#' @param ... Parameters passed to the \link[semPlot]{semPaths} function
#' @export
dot_graph.cfa_model <- function(model, title = "", theme = NULL, what = "std", whatLabels = "std", ...){
query_install("semPlot", "Plotting models from lavaan is not implemented yet. semPlot is required as a fallback.")
if(requireNamespace("semPlot", quietly = TRUE)){
return(semPlot::semPaths(model$lavaan_output, what = what, whatLabels = whatLabels,...))
} else {
return("")
}
}
#' Plotting of covariance based SEMs models using semPLOT
#'
#' @rdname dot_graph
#' @param model the CBSEM model
#' @param title Unused
#' @param theme Unused
#' @param what The metric to use for edges ("path", "est", "std", "eq", "col")
#' @param whatLabels The metric to use for edge labels
#' @param ... Parameters passed to the \link[semPlot]{semPaths} function
#' @export
dot_graph.cbsem_model <- function(model, title = "", theme = NULL, what = "std", whatLabels = "std", ...){
query_install("semPlot", "Plotting models from lavaan is not implemented yet. semPlot is required as a fallback.")
if(requireNamespace("semPlot", quietly = TRUE)){
return(
semPlot::semPaths(model$lavaan_output, what = what, whatLabels = whatLabels,...)
)
} else {
return("")
}
}
#' @export
dot_graph.default <- function(...){
stop("Whoops. This shouldn't have happened. Did you use a SEMinR model? If yes, please let us know if this happens and how.")
}
#' Convert a seminr measurement model to a Graphviz representation
#'
#' @rdname dot_graph
#' @param model Model created with \code{seminr}.
#' @param title An optional title for the plot
#' @param theme Theme created with \code{\link{seminr_theme_create}}.
#' @param ... Unused
#'
# @return The path model as a formatted string in dot language.
#' @export
#'
#' @examples
#' # - - - - - - - - - - - - - - - -
#' # Example for plotting a measurement model
#' mobi_mm <- constructs(
#' reflective("Image", multi_items("IMAG", 1:5)),
#' reflective("Expectation", multi_items("CUEX", 1:3)),
#' reflective("Quality", multi_items("PERQ", 1:7)),
#' reflective("Value", multi_items("PERV", 1:2)),
#' reflective("Satisfaction", multi_items("CUSA", 1:3)),
#' reflective("Complaints", single_item("CUSCO")),
#' reflective("Loyalty", multi_items("CUSL", 1:3))
#' )
#' dot_graph(mobi_mm, title = "Preview measurement model")
dot_graph.measurement_model <-
function(model,
title = "",
theme = NULL, ...
){
unusedParams <- list(...)
if (length(unusedParams))
stop('Unused parameters: ', paste(unusedParams, collapse = ', '))
if (is.null(theme)) {
thm <- seminr_theme_get()
} else {
thm <- theme
}
# THIS IS AN ARTIFICAL MODEL THAT LETS ME REUSE THE OLD PLOTTING FUNCTION,
# THIS is unnecessary complex(?).
mm <- mm2matrix(model)
as.data.frame(mm) -> mmodel
hocs <- model$higher_order_composite
a_model <- list(measurement_model = model,
mmMatrix = mm,
smMatrix = matrix(rep(unique(mmodel$construct),2),
ncol = 2,
nrow = length(unique(mmodel$construct))),
outer_weights = matrix(c(1), # add only 1s
ncol = length(unique(mmodel$construct) ),
dimnames = list(unique(mmodel$measurement),
unique(mmodel$construct) ),
nrow = length(unique(mmodel$measurement) )
),
outer_loadings = matrix(c(1), # add only 1s
ncol = length(unique(mmodel$construct) ),
dimnames = list(unique(mmodel$measurement),
unique(mmodel$construct) ),
nrow = length(unique(mmodel$measurement) )
),
constructs = unique(mmodel$construct),
mmVariables = unique(mmodel$measurement)
)
if (length(hocs) > 0) {
a_model$hoc <- TRUE
}
class(a_model) <- "pls_model"
# adjust themes to correct for artifical information
thm$mm.edge.width_multiplier <- 1
thm$mm.edge.label.show <- FALSE
dot_graph(a_model, title = title, theme = thm, measurement_only = TRUE)
}
#' Convert a seminr structural model to a Graphviz representation
#'
#' @rdname dot_graph
#' @param model Model created with \code{seminr}.
#' @param title An optional title for the plot
#' @param theme Theme created with \code{\link{seminr_theme_create}}.
#' @param ... Unused
#'
# @return The path model as a formatted string in dot language.
#' @export
#'
#' @examples
#' # - - - - - - - - - - - - - - - -
#' # Example for plotting a structural model
#' mobi_sm <- relationships(
#' paths(from = "Image", to = c("Expectation", "Satisfaction", "Loyalty")),
#' paths(from = "Expectation", to = c("Quality", "Value", "Satisfaction")),
#' paths(from = "Quality", to = c("Value", "Satisfaction")),
#' paths(from = "Value", to = c("Satisfaction")),
#' paths(from = "Satisfaction", to = c("Complaints", "Loyalty")),
#' paths(from = "Complaints", to = "Loyalty")
#' )
#' res <- dot_graph(mobi_sm, title = "Preview structural model")
#'
#' \dontrun{
#' DiagrammeR::grViz(res)
#' }
dot_graph.structural_model <-
function(model,
title = "",
theme = NULL, ...
){
unusedParams <- list(...)
if (length(unusedParams))
stop('Unused parameters: ', paste(unusedParams, collapse = ', '))
if (is.null(theme)) {
thm <- seminr_theme_get()
} else {
thm <- theme
}
# THIS IS AN ARTIFICAL MODEL THAT LETS ME REUSE THE OLD PLOTTING FUNCTION,
# THIS is unnecessary complex(?).
sm_constructs <- unique( c(model[,1], model[,2]) )
mm_list <- list()
for (i in sm_constructs) {
mm_list[[i]] <- reflective(i, paste0(i,"_dummy"))
}
measurement_model <- do.call(constructs, mm_list)
mm <- mm2matrix( measurement_model )
as.data.frame(mm) -> mmodel
a_model <- list(measurement_model = measurement_model,
mmMatrix = matrix(),
smMatrix = model,
outer_weights = matrix(c(1), # add only 1s
ncol = length(unique(mmodel$construct)),
dimnames = list(unique(mmodel$measurement),
unique(mmodel$construct)),
nrow = length(unique(mmodel$measurement))
),
path_coef = matrix(c(1),
ncol = length(sm_constructs),
nrow = length(sm_constructs),
dimnames = list(sm_constructs, sm_constructs)),
constructs = unique(mmodel$construct),
mmVariables = unique(mmodel$measurement)
)
class(a_model) <- "pls_model"
thm$sm.edge.width_multiplier <- 1
thm$sm.edge.label.show <- FALSE
dot_graph(a_model, title = title, theme = thm, structure_only = TRUE)
}
#' Convert a seminr model to Graphviz representation
#'
#' @rdname dot_graph
#' @param model Model created with \code{seminr}.
#' @param title An optional title for the plot
#' @param theme Theme created with \code{\link{seminr_theme_create}}.
#' @param measurement_only Plot only measurement part
#' @param structure_only Plot only structure part
#'
# @return The path model as a formatted string in dot language.
#' @export
#'
# @examples
dot_graph.specified_model <- function(model,
title = "",
theme = NULL,
measurement_only = FALSE,
structure_only = FALSE, ...
) {
unusedParams <- list(...)
if (length(unusedParams))
stop('Unused parameters: ', paste(unusedParams, collapse = ', '))
if (is.null(theme)) {
thm <- seminr_theme_get()
} else {
thm <- theme
}
# THIS IS AN ARTIFICAL MODEL THAT LETS ME REUSE THE OLD PLOTTING FUNCTION,
# THIS is unnecessary complex(?).
#<- unique(model$structural_model[,1])
#mm_list <- list()
#for (i in sm_constructs) {
# mm_list[[i]] <- reflective(i, paste0(i,"_dummy"))
#}
#measurement_model <- do.call(constructs, mm_list)
#mm <- mm2matrix( measurement_model )
#as.data.frame(mm) -> mmodel
measurement_model <- model$measurement_model
mm <- mm2matrix( measurement_model )
as.data.frame(mm) -> mmodel
sm_constructs <- unique(mmodel$construct)
weight_matrix <- matrix(c(1), # add only 1s
ncol = length(unique(mmodel$construct)),
dimnames = list(unique(mmodel$measurement),
unique(mmodel$construct)),
nrow = length(unique(mmodel$measurement))
)
path_matrix <- matrix(c(1),
ncol = length(sm_constructs),
nrow = length(sm_constructs),
dimnames = list(sm_constructs, sm_constructs))
# specify artificial model
a_model <- list(measurement_model = measurement_model,
mmMatrix = mm,
smMatrix = model$structural_model,
outer_weights = weight_matrix,
outer_loadings = weight_matrix,
path_coef = path_matrix,
constructs = unique(mmodel$construct),
mmVariables = unique(mmodel$measurement)
)
class(a_model) <- "pls_model"
thm$sm.edge.width_multiplier <- 1
thm$sm.edge.label.show <- FALSE
thm$mm.edge.width_multiplier <- 1
thm$mm.edge.label.show <- FALSE
dot_graph(a_model, title = title, theme = thm, measurement_only = measurement_only, structure_only, structure_only)
}
#' Convert a seminr model to Graphviz representation
#'
#' @rdname dot_graph
#' @param model Model created with \code{seminr}.
#' @param title An optional title for the plot
#' @param theme Theme created with \code{\link{seminr_theme_create}}.
#' @param measurement_only Plot only measurement part
#' @param structure_only Plot only structure part
#'
# @return The path model as a formatted string in dot language.
#' @export
#'
# @examples
dot_graph.boot_seminr_model <- function(model,
title = "",
theme = NULL,
measurement_only = FALSE,
structure_only = FALSE, ...
) {
# the origingal pls method is capable of plotting boot strapped models
dot_graph.pls_model(model, title, theme, measurement_only, structure_only, ...)
}
#' Convert a seminr model to Graphviz representation
#'
#' @rdname dot_graph
#' @param model Model created with \code{seminr}.
#' @param title An optional title for the plot
#' @param theme Theme created with \code{\link{seminr_theme_create}}.
#' @param measurement_only Plot only measurement part
#' @param structure_only Plot only structure part
#'
# @return The path model as a formatted string in dot language.
#' @export
#'
dot_graph.pls_model <- function(model,
title = "",
theme = NULL,
measurement_only = FALSE,
structure_only = FALSE, ...
) {
if (is.null(theme)) {
thm <- seminr_theme_get()
} else {
if (inherits(theme, "function")) {
thm <- theme()
} else {
thm <- theme
}
}
if (thm$plot.title == "") {
thm$plot.title <- title
}
global_style <- get_global_style(theme = thm)
# rewrite size defaults in theme
thm$sm.node.width <- get_construct_element_size(model, thm)[1]
thm$sm.node.height <- get_construct_element_size(model, thm)[2] * 2 # two lines, could be optimized
thm$mm.node.width <- get_manifest_element_size(model, thm)[1]
thm$mm.node.height <- get_manifest_element_size(model, thm)[2]
# generate components ---
sm <- ""
mm <- ""
# replace needed parts
# do not change the order in if-else statement as some artificial models only work with either function
if (measurement_only) {
sm <- dot_component_sm_parts(model = model, theme = thm)
} else {
sm <- dot_component_sm(model = model, theme = thm, structure_only = structure_only)
}
if (structure_only) {
mm <- ""
} else {
mm <- dot_component_mm(model = model, theme = thm)
}
# do not change end - - - -
glue_dot(paste0("digraph G {\n",
"\n<<global_style>>\n",
"\n<<sm>>",
"\n<<mm>>",
"\n}\n"))
}
# ___________________ ----
# Graph options ------------------
#' Get dot string for global theme options
#' @keywords internal
#' @param theme a theme
#' @param layout The layout engine (default: dot)
get_global_style <- function(theme, layout = "dot") {
glue_dot(paste0("// ----------------------\n",
"// General graph settings\n",
"// ----------------------\n",
"graph [\n",
"charset = \"UTF-8\",\n",
"layout = ", layout, ",\n",
"label = \"<<theme$plot.title>>\",\n",
"fontsize = <<theme$plot.title.fontsize>>,\n",
"fontcolor = <<theme$plot.title.fontcolor>>,\n",
"fontname = <<theme$plot.fontname>>,\n",
"rankdir = LR,\n",
"labelloc = t,\n",
"splines = <<theme$plot.splines>>\n",
"bgcolor = <<theme$plot.bgcolor>>\n",
"]\n"))
}
# 1. Node options ----
#' Gets the optimal size for construct elements in the plot
#'
#' Currently orients on reflective theme settings
#'
#' @param model the model to use
#' @param theme the theme to use
#'
#' @return Returns a two-element vector with c(width, height)
get_construct_element_size <- function(model, theme) {
r_offset <- get_sm_element_offset(theme$construct.reflective.shape)
a_offset <- get_sm_element_offset(theme$construct.compositeA.shape)
b_offset <- get_sm_element_offset(theme$construct.compositeB.shape)
c_width_offset <- max(r_offset$width, a_offset$width, b_offset$width)
c_height_offset <- max(r_offset$height, a_offset$height, b_offset$height)
construct_width <- max(
graphics::strwidth(model$constructs, font = theme$sm.node.label.fontsize, units = "in")
) + c_width_offset
construct_height <- max(
graphics::strheight(model$constructs, font = theme$sm.node.label.fontsize, units = "in")
) + c_height_offset
c(construct_width, construct_height)
}
#' Gets the optimal size for manifest elements in the plot
#'
#' Currently orients on reflective theme settings
#'
#' @param model the model to use
#' @param theme the theme to use
#'
#' @return Returns a two-element vector with c(width, height)
get_manifest_element_size <- function(model, theme) {
r_offset <- get_mm_element_offset(theme$manifest.reflective.shape)
a_offset <- get_mm_element_offset(theme$manifest.compositeA.shape)
b_offset <- get_mm_element_offset(theme$manifest.compositeB.shape)
i_width_offset <- max(r_offset$width, a_offset$width, b_offset$width)
i_height_offset <- max(r_offset$height, a_offset$height, b_offset$height)
item_width <- max(
graphics::strwidth(model$mmVariables,font = theme$mm.node.label.fontsize, units = "in")
) + i_width_offset
item_height <- max(
graphics::strheight(model$mmVariables,font = theme$mm.node.label.fontsize, units = "in")
) + i_height_offset
c(item_width, item_height)
}
# 2. Edge options ----
# generic formatting function for bootstrapped edges
format_edge_boot_label <- function(template, variable, value, tvalue, pvalue, stars, civalue) {
content <- glue::glue(template)
paste0(", label = < ",
content,
" >")
}
# generic formatting function for edges
format_edge_label <- function(template, variable, value) {
glue::glue(template)
}
#' Returns the type of a construct from a model
#' @param model the model to get the type from
#' @param construct the character string name of the construct
#' @return Returns a character string
get_construct_type <- function(model, construct) {
#if (!(construct %in% model$constructs)) {
# stop(paste("Construct", construct, "does not exist")) # scaled interactions ?
#}
if (grepl("\\*", construct)) {
return("interaction")
}
for (i in 1:length(model$measurement_model)) {
cst <- model$measurement_model[[i]]
# warning interaction are functions do not access their indexes
if (!inherits(cst, "function")) {
if (cst[[1]] == construct) {
construct_type <- cst[[3]]
}
}
}
return(construct_type)
}
#' extract bootstrapped statistics from an edge using a row_index
#'
#' @param ltbl a table of bootstrapped values (weights, loadings, path coefficients)
#' @param row_index the index for the specific edge to extract
#' @param model the model to use
#' @param theme the theme to use
extract_bootstrapped_values <- function(ltbl, row_index, model, theme) {
t_value <- ltbl[rownames(ltbl) == row_index, 4]
pvalue <- stats::pt(abs(t_value), nrow(model$data) - 1, lower.tail = FALSE)
list(
mean = round(ltbl[rownames(ltbl) == row_index, 1], theme$plot.rounding),
lower = round(ltbl[rownames(ltbl) == row_index, 5], theme$plot.rounding),
upper = round(ltbl[rownames(ltbl) == row_index, 6], theme$plot.rounding),
tvalue = round(t_value, theme$plot.rounding),
p = pvalue
)
}
# Needs tweaking ----
# gets the offsets for predefined shapes
get_mm_element_offset <- function(element) {
offset_table <- data.frame(
shape = c("box", "rectangle", "ellipse", "hexagon"),
width = c(0.0, 0, 0.4, 0.4),
height = c(0.05, 0.05, 0.4, 0.3)
)
offset_table[offset_table$shape == element, 2:3]
}
# gets the offsets for predefined shapes
get_sm_element_offset <- function(element) {
offset_table <- data.frame(
shape = c("box", "rectangle", "ellipse", "hexagon"),
width = c(0.2, 0.2, 0.4, 0.4),
height = c(0.1, 0.1, 0.4, 0.3)
)
offset_table[offset_table$shape == element, 2:3]
}
# ___________________ ----
# 1. Structural Model ----------------------
# construct structural model using subgraphs
dot_component_sm <- function(model, theme, structure_only = FALSE) {
sm_nodes <- extract_sm_nodes(model, theme, structure_only = structure_only)
sm_node_style <- get_sm_node_style(theme)
sm_edges <- extract_sm_edges(model, theme)
sm_edge_style <- get_sm_edge_style(theme)
glue_dot(paste0("// --------------------\n",
"// The structural model\n",
"// --------------------\n",
"subgraph sm {\n",
"rankdir = LR;\n",
"node [\n",
"<<sm_node_style>>\n",
"]\n",
"<<sm_nodes>>\n",
"edge [\n",
"<<sm_edge_style>>\n",
"]\n",
"<<sm_edges>>\n",
"}\n"))
}
# Special case used when plotting measurement models (ignores structural model edges!)
dot_component_sm_parts <- function(model, theme){
#used for plotting measurement models
# This is a "hacky" solution. Because we create artificial models
# and did not want to create an artificial measurement model
# this function is used to plot only the SM part.
sm_nodes <- extract_sm_nodes(model, theme)
sm_node_style <- get_sm_node_style(theme)
glue_dot(paste0("// --------------------\n",
"// The structural model\n",
"// --------------------\n",
"subgraph sm {\n",
"rankdir = LR;\n",
"node [\n",
"<<sm_node_style>>\n",
"]\n",
"<<sm_nodes>>\n",
"}\n"))
}
# 1.1 SM-Nodes ----
#' Helper function that applies formatting to each construct
#'
#' @param model the model to use
#' @param theme the theme to use
#' @param structure_only is this called in a structure_only model
#'
#' @return Returns a string of the structural model in dot notation.
extract_sm_nodes <- function(model, theme, structure_only = FALSE) {
sm_nodes <- model$constructs
# Add additional SM nodes for submodel
for (construct in model$constructs) {
construct_type <- get_construct_type(model, construct)
if (startsWith(construct_type, "HOC") && !structure_only) {
# row_index <- grepl(construct, model$mmMatrix[,1])
row_index <- model$mmMatrix[,1] == construct
result <- model$mmMatrix[row_index, 2]
sm_nodes <- c(sm_nodes, result)
}
}
sm_nodes <- sapply(sm_nodes, format_sm_node, model, theme)
sm_nodes <- paste0(sm_nodes, collapse = "\n")
return(sm_nodes)
}
# format structural model node where appropriate
format_sm_node <- function(construct, model, theme){
# this is the unicode symbol for ^2
if ( theme$plot.specialcharacters ) {
squared_symbol <- "\U00B2"
} else {
squared_symbol <- "^2"
}
# Init node as empty string
formatted_node <- ""
# decide whether or not to use adj r^2
if (theme$plot.adj) {
# the index in the rSquared table for adj. r^2 is 2
r_index <- 2
r_string <- "adj. "
} else {
# the index in the rSquared table for r^2 is 1
r_index <- 1
r_string <- ""
}
# detect construct type
shape_string <- get_sm_node_shape(model, construct, theme)
#detect if exogenous construct
if (construct %in% colnames(model$rSquared)) {
rstring <- paste0(r_string, "r", squared_symbol, " = ",
round(model$rSquared[r_index, construct], theme$plot.rounding))
label_string <- format_endo_node_label(theme, construct, rstring)
formatted_node <- paste0("\"", construct, "\" ",
"[label=<", label_string,
">", shape_string, "]")
} else {
label_string <- format_exo_node_label(theme, construct)
formatted_node <- paste0("\"", construct, "\"" , " [label=<",
label_string,
">", shape_string, "]")
}
return(formatted_node)
}
# returns the style of all SM nodes
get_sm_node_style <- function(theme) {
glue_dot(paste0("shape = ellipse,\n", #fall-back if something breaks
"color = <<theme$sm.node.color>>,\n",
"fillcolor = <<theme$sm.node.fill>>,\n",
"style = filled,\n",
"fontsize = <<theme$sm.node.label.fontsize>>,\n",
"fontcolor = <<theme$sm.node.label.fontcolor>>,\n",
"height = <<theme$sm.node.height>>,\n",
"width = <<theme$sm.node.width>>,\n",
"fontname = <<theme$plot.fontname>>,\n",
"fixedsize = true\n"))
}
#' Get a string to insert into a node specification using the themed shape
#'
#' @param model the model to use
#' @param construct the construct to use
#' @param theme the theme to use
#'
#' @return Returns a string that determines the shape of a node
get_sm_node_shape <- function(model, construct, theme) {
construct_type <- get_construct_type(model, construct)
result <- switch(construct_type,
"interaction" = ", shape = ellipse",
"C" = paste0(", shape = ", theme$construct.reflective.shape),
"B" = paste0(", shape = ", theme$construct.compositeB.shape),
"A" = paste0(", shape = ", theme$construct.compositeA.shape),
"HOCA" = paste0(", shape = ", theme$construct.compositeA.shape),
"HOCB" = paste0(", shape = ", theme$construct.compositeB.shape),
"UNIT" = paste0(", shape = ", theme$construct.compositeB.shape)
)
return(result)
}
#' Helps to render a node label for exogenous variables
#'
#' @param theme the theme to use
#' @param name the content of the name placeholder
#'
#' @return Returns the formatted string
format_exo_node_label <- function(theme, name) {
glue::glue(theme$sm.node.exo.template)
}
#' Helps to render a node label for endogenous variables
#'
#' @param theme the theme to use
#' @param name the content of the name placeholder
#' @param rstring the content of the rstring placeholder
#'
#' @return Returns the formatted string
format_endo_node_label <- function(theme, name, rstring) {
glue::glue(theme$sm.node.endo.template)
}
# 1.2 SM-Edges ----
# extract structural model edges from a seminr model
extract_sm_edges <- function(model, theme, weights = 1) {
# Get information about model
nr <- nrow(model$smMatrix)
nc <- ncol(model$smMatrix)
sm <- model$smMatrix
# start with empty set of edges
sm_edges <- c()
# Unicode for small mathematical symbols
# TODO: does not work in <B> sections, yet(?)
if ( theme$plot.specialcharacters ) {
beta <- "\U0001D6FD"
gamma <- "\U0001D6FE" # non-bold
gamma <- "\U0001D738" # bold
} else {
beta <- "beta"
gamma <- "gamma"
}
# for every path add an edge
for (i in 1:nrow(sm)) {
# since one estimation technique is used the default is to used betas
if (theme$sm.edge.label.all_betas) {
letter <- beta
} else {
if ( !(sm[i,1] %in% colnames(model$rSquared))) {
letter <- gamma # when it is determined only by exogenous variables use gamma
} else {
letter <- beta
}
}
# build label components
if ("boot_seminr_model" %in% class(model)) {
# format bootstrapped ---
# create a summary for summary stats
smry <- summary(model)
row_index <- paste0(sm[i, 1], " -> ", sm[i,2])
ltbl <- smry$bootstrapped_paths
boot_values <- extract_bootstrapped_values(ltbl, row_index, model, theme)
# bmean <- round(ltbl[rownames(ltbl) == row_index, 2], theme$plot.rounding)
# blower <- round(ltbl[rownames(ltbl) == row_index, 5], theme$plot.rounding)
# bupper <- round(ltbl[rownames(ltbl) == row_index, 6], theme$plot.rounding)
# bt <- ltbl[rownames(ltbl) == row_index, 4]
#
# # TODO: Verify method to calculate p values (seems correct, maybe user land?)
# bp <- stats::pt(abs(bt), nrow(model$data) - 1, lower.tail = FALSE)
# show element depending on theme
if (theme$sm.edge.boot.show_t_value) {
tvalue <- paste0("t = ", round(boot_values[["tvalue"]], theme$plot.rounding))
} else
tvalue <- ""
if (theme$sm.edge.boot.show_p_value) {
pvalue <- paste0("p ", pvalr(boot_values[["p"]], html = TRUE))
} else
pvalue <- ""
if (theme$sm.edge.boot.show_p_stars) {
stars <- psignr(boot_values[["p"]], html = TRUE)
} else
stars <- ""
if (theme$sm.edge.boot.show_ci) {
civalue <- paste0("95% CI [", boot_values[["lower"]], ", ", boot_values[["upper"]], "]")
} else
civalue <- ""
edge_width <- paste0(", penwidth = ",
abs(boot_values[["mean"]] * theme$sm.edge.width_multiplier) +
theme$sm.edge.width_offset)
edge_style <- get_value_dependent_sm_edge_style(boot_values[["mean"]], theme)
coef <- boot_values[["mean"]]
} else {
# format regular pls model ---
tvalue <- ""
pvalue <- ""
civalue <- ""
stars <- ""
coef <- round(model$path_coef[sm[i, 1], sm[i,2]], theme$plot.rounding)
edge_width <- paste0(", penwidth = ", (abs(coef * theme$sm.edge.width_multiplier) + theme$sm.edge.width_offset))
edge_style <- get_value_dependent_sm_edge_style(coef, theme)
}
# build the label
if (theme$sm.edge.label.show) {
edge_label <- format_edge_boot_label(theme$sm.edge.boot.template, variable = letter, value = coef, tvalue, pvalue, stars, civalue )
} else {
edge_label <- ""
}
if (theme$plot.randomizedweights) {
# Does this help with determinism in the layout?
weights <- weights + stats::runif(1)
}
# add the weight
edge_weight <- paste0("weight = ", weights)
sm_edges <- c(sm_edges,
paste0("\"", sm[i, 1], "\" -> {\"", sm[i, 2], "\"}","[", edge_weight, edge_label, edge_width, edge_style, "]"))
}
sm_edges <- paste0(sm_edges, collapse = "\n")
return(sm_edges)
}
# style for all SM edges
get_sm_edge_style <- function(theme){
minlen_str <- ""
if (!is.na(theme$sm.edge.minlen)) {
minlen_str <- glue_dot("minlen = <<theme$sm.edge.minlen>>,\n")
}
glue_dot(paste0("color = <<theme$sm.edge.positive.color>>,\n", # fallback
"fontsize = <<theme$sm.edge.label.fontsize>>,\n",
"fontcolor = <<theme$sm.edge.label.fontcolor>>,\n",
"fontname = <<theme$plot.fontname>>,\n",
"<<minlen_str>>",
#"constraint=false,", # TODO: consider optional parameter
"dir = both,\n",
"arrowhead = normal,\n",
"arrowtail = none"))
}
#' Formats the style of the structural model edges
#'
#' @param value value to compare for negativity
#' @param theme the theme to use
#'
#' @return Returns the style for the edge (both style and color)
get_value_dependent_sm_edge_style <- function(value, theme){
edge_style <- paste0(", style = ", theme$sm.edge.positive.style,
", color = ", theme$sm.edge.positive.color)
if (value < 0) {
edge_style <- paste0(", style = ", theme$sm.edge.negative.style,
", color = ", theme$sm.edge.negative.color)
}
edge_style
}
# ___________________ ----
# 2. Measurement Model ----------------------
#' Tests whether the i_th construct is endogenous or not
#'
#' @param model the model object
#' @param index the index of the construct to test
#'
#' @return whether the construct is endogenous or not
#' @export
is_sink <- function(model, index) {
# get the mm_coding
mm_coding <- extract_mm_coding(model)
# Code explanation
# as the lower order constructs are not part of the structural model,
# we cannot extract their coding directly
# where does the indexed construct appear as a measurement?
idx <- model$mmMatrix[,2] == mm_coding[index, 1]
#get that construct's type
index_type <- model$mmMatrix[idx,3]
# is it a HOC?
is_higher_order_measurement <- startsWith(index_type, "HOC")
if(any(is_higher_order_measurement)) {
# cannot be sink
return(FALSE)
}
# otherwise test if it never appears in source
issink <- !any(mm_coding[index, ] %in% model$smMatrix[,1])
return(issink)
}
#' Generates the dot code for the measurement model
#'
#' @param model the model to use
#' @param theme the theme to use
dot_component_mm <- function(model, theme) {
sub_components_mm <- c(paste0("// ---------------------\n",
"// The measurement model\n",
"// ---------------------\n"))
# we use mmMatrix because model$constructs does not contain HOCs
if (is.null(model$hoc)) {
mm_count <- length(intersect(unique(model$smMatrix),unique(model$mmMatrix[,1 ])))
} else {
mm_count <- length(intersect(unique(c(model$smMatrix, model$first_stage_model$smMatrix)),unique(model$mmMatrix[,1 ])))
}
for (i in 1:mm_count) {
sub_component <- dot_subcomponent_mm(i, model, theme)
sub_components_mm <- c(sub_components_mm, sub_component)
}
glue_dot(paste0(sub_components_mm, collapse = "\n"))
}
#' generates the dot code for a subgraph (per construct)
#'
#' @param index the index of the construct
#' @param model the model to use
#' @param theme the theme to use
dot_subcomponent_mm <- function(index, model, theme) {
mm_coding <- extract_mm_coding(model)
node_style <- get_mm_node_style(theme)
# test-flags for component types
is_reflective <- mm_coding[index, 2] == "C"
is_interaction <- mm_coding[index, 2] == "interaction"
# is_higher_order <- startsWith(mm_coding[index, 2], "HOC") # maybe we need this later?
# debug:
# print(mm_coding[index, ])
# no measurement for interaction terms
# TODO: two-stage interaction
if (is_interaction) {
return("")
}
#if (is_reflective) {
# edge_style <- get_mm_edge_style(theme, forward = FALSE)
#} else {
# edge_style <- get_mm_edge_style(theme, forward = TRUE)
#}
construct_type <- get_construct_type(model, mm_coding[index, 1])
flip <- is_sink(model, index)
edge_style <- get_mm_edge_style(theme, construct_type, flip)
nodes <- extract_mm_nodes(index, model, theme)
edges <- extract_mm_edges(index, model, theme)
sub_component <- glue_dot(paste0(c("subgraph construct_<<index>> {",
"node [",
"<<node_style>>",
"]",
"<<nodes>>",
"edge [",
"<<edge_style>>",
"]",
"<<edges>>",
"}\n"),
collapse = "\n"))
return(sub_component)
}
#' extracts the constructs and their types from the model
#'
#' @param model the model to use
extract_mm_coding <- function(model) {
# iterate over all constructs in the mmMatrix
constructs <- constructs_in_model(model)
# create output matrix
mm_coding <- matrix(nrow = length(constructs$construct_names),
ncol = 2,
data = c(constructs$construct_names, constructs$construct_types))
colnames(mm_coding) <- c("name", "type")
return(mm_coding)
}
# 2.1 MM-Nodes ----
#' get global measurement model node style
#'
#' @param theme the theme to use
get_mm_node_style <- function(theme) {
glue_dot(paste0("shape = box,\n",
"color = <<theme$mm.node.color>>,\n",
"fillcolor = <<theme$mm.node.fill>>,\n",
"style = filled,\n",
"fontsize = <<theme$mm.node.label.fontsize>>,\n",
"fontcolor = <<theme$mm.node.label.fontcolor>>,\n",
"height = <<theme$mm.node.height>>,\n",
"width = <<theme$mm.node.width>>,\n",
"fontname = <<theme$plot.fontname>>,\n",
"fixedsize = true\n"))
}
#' gets the individual nodes and applies formatting
#'
#' @param index the index of the construct
#' @param model the model to use
#' @param theme the theme to use
extract_mm_nodes <- function(index, model, theme) {
mm_coding <- extract_mm_coding(model)
mm_matrix <- model$mmMatrix
mm_matrix_subset <- mm_matrix[mm_matrix[, 1] == mm_coding[index, 1], ,drop = FALSE] # Should now always be a matrix
shape <- get_mm_node_shape(model, mm_matrix_subset[1,1], theme)
nodes <- paste0(
paste0("\"",mm_matrix_subset[, 2],"\" [label = \"", mm_matrix_subset[, 2], "\"", shape, "]"),
collapse = "\n")
return(nodes)
}
#' Get a string to insert into a node specification using the themed shape
#'
#' @param model the model to use
#' @param construct the construct to use
#' @param theme the theme to use
#'
#' @return Returns a string that determines the shape of a node
get_mm_node_shape <- function(model, construct, theme) {
construct_type <- get_construct_type(model, construct)
result <- switch(construct_type,
"interaction" = ", shape = ellipse",
"C" = paste0(", shape = ", theme$manifest.reflective.shape),
"B" = paste0(", shape = ", theme$manifest.compositeB.shape),
"A" = paste0(", shape = ", theme$manifest.compositeA.shape),
"HOCA" = paste0(", shape = ", theme$manifest.compositeA.shape),
"HOCB" = paste0(", shape = ", theme$manifest.compositeB.shape),
"UNIT" = paste0(", shape = ", theme$construct.compositeB.shape)
)
return(result)
}
# 2.2 MM-Edges ----
#' individual styles for measurement model edges
#'
#' @param theme the theme to use
#' @param construct_type Forward direction?
#' @param flip invert the arrow direction because of sink?
get_mm_edge_style <- function(theme, construct_type, flip = FALSE){
# read direction for matching construct type from theme
if (construct_type == "C") {
direction <- theme$construct.reflective.arrow
}
if (construct_type == "A" || construct_type == "HOCA") {
direction <- theme$construct.compositeA.arrow
}
if (construct_type == "B" || construct_type == "HOCB" || construct_type == "UNIT") {
direction <- theme$construct.compositeB.arrow
}
# flip the direction if sink
if(flip){
if(direction == "forward") {
direction <- "backward"
} else
if(direction == "backward") {
direction <- "forward"
}
}
# generate arrows from direction
if (direction == "forward") {
arrowhead <- "normal"
arrowtail <- "none"
}
if (direction == "backward") {
arrowhead <- "none"
arrowtail <- "normal"
}
if (direction == "none") {
arrowhead <- "none"
arrowtail <- "none"
}
if (!is.na(theme$mm.edge.minlen)) {
minlen_str <- glue_dot("minlen = <<theme$mm.edge.minlen>>,")
} else {
minlen_str <- ""
}
glue_dot(paste0(c("color = <<theme$mm.edge.positive.color>>,", #default as fallback
"fontsize = <<theme$mm.edge.label.fontsize>>,",
"fontcolor = <<theme$mm.edge.label.fontcolor>>,",
"fontname = <<theme$plot.fontname>>,",
"<<minlen_str>>",
"dir = both",
"arrowhead = <<arrowhead>>",
"arrowtail = <<arrowtail>>"),
collapse = "\n"))
}
#' gets the mm_edge value (loading, weight) for bootstrapped and regular models
#'
#' @param model the model to use
#' @param theme the theme to use
#' @param indicator the indicator to use
#' @param construct the construct to use
extract_mm_edge_value <- function(model, theme, indicator, construct){
use_weights <- use_construct_weights(theme,
get_construct_type(model, construct))
# TODO: Redundancy in the next few lines can it be permanently deleted?
# if ("boot_seminr_model" %in% class(model)) {
# boot_construct <- paste0(construct, " Boot Mean")
# if (use_weights) {
# loading <-
# round(model$outer_weights[indicator, boot_construct], theme$plot.rounding)
# } else {
# loading <-
# round(model$outer_loadings[indicator, boot_construct], theme$plot.rounding)
# }
# }
# if ("pls_model" %in% class(model)) {
if (use_weights) {
loading <-
round(model$outer_weights[indicator, construct], theme$plot.rounding)
} else {
loading <-
round(model$outer_loadings[indicator, construct], theme$plot.rounding)
}
# }
return(loading)
}
#' Should a construct type use weights or loadings
#'
#' @param theme The theme to use
#' @param construct_type the construct type to test
#'
#' @return TRUE if weights should be used, FALSE if loadings
#' @keywords internal
#'
use_construct_weights <- function(theme, construct_type) {
if (construct_type == "C") {
return(theme$construct.reflective.use_weights)
}
if (construct_type == "A" || construct_type == "HOCA") {
return(theme$construct.compositeA.use_weights)
}
if (construct_type == "B" || construct_type == "HOCB" || construct_type == "UNIT") {
return(theme$construct.compositeB.use_weights)
}
}
#' extract mm edges from model for a given index of all constructs
#'
#' @param index the index of the construct
#' @param model the model to use
#' @param theme the theme to use
#' @param weights a default weight for measurment models (high values suggested)
extract_mm_edges <- function(index, model, theme, weights = 1000) {
mm_coding <- extract_mm_coding(model)
mm_matrix <- model$mmMatrix
# get row_index of all matching mm_matrix rows
matching_rows <- mm_matrix[, 1] == mm_coding[index, 1]
mm_matrix_subset <- mm_matrix[matching_rows, ,drop = FALSE]
edges <- ""
# determine letter to use (What is with A and B type constructs?)
# Small mathematical lambda
if (theme$plot.specialcharacters) {
lambda <- "\U0001D706" # nonbold
# lambda <- "\U0001D740" #bold
} else {
lambda <- "lambda"
}
for (i in 1:nrow(mm_matrix_subset)) {
if (theme$plot.randomizedweights) {
# Does this help with determinism in the layout?
weights <- weights + stats::runif(1)
}
manifest_variable <- mm_matrix_subset[i, 2]
construct_variable = mm_matrix_subset[i, 1]
use_weights <- use_construct_weights(theme,
get_construct_type(model, construct_variable))
# If interaction variable, we skip
if (grepl("\\*", manifest_variable)) {
next
}
letter <- lambda
# Should I use weights?
if (use_weights) {
letter <- "w"
}
if (inherits(model, "boot_seminr_model")) {
# bootstrapped version ---
smry <- summary(model)
row_index <-
paste0(manifest_variable, " -> ", construct_variable)
ltbl <- smry$bootstrapped_loadings
use_weights <- use_construct_weights(theme,
get_construct_type(model, construct_variable))
if (use_weights) {
ltbl <- smry$bootstrapped_weights
}
boot_values <-
extract_bootstrapped_values(ltbl, row_index, model, theme)
if (theme$mm.edge.boot.show_t_value) {
tvalue <-
paste0("t = ", round(boot_values[["tvalue"]], theme$plot.rounding))
}
if (theme$mm.edge.boot.show_p_value) {
pvalue <- paste0("p ", pvalr(boot_values[["p"]], html = TRUE))
}
if (theme$mm.edge.boot.show_p_stars) {
stars <- psignr(boot_values[["p"]], html = TRUE)
}
if (theme$mm.edge.boot.show_ci) {
civalue <-
paste0("95% CI [", boot_values[["lower"]], ", ", boot_values[["upper"]], "]")
}
} else {
# non-bootstrapped version ---
tvalue <- ""
pvalue <- ""
stars <- ""
civalue <- ""
}
# extract_mm_edge_value gets the correct value for bootstrapped and non bootstrapped models
loading <- extract_mm_edge_value(model, theme,
indicator = manifest_variable,
construct = construct_variable)
if (theme$mm.edge.label.show) {
edge_label <- format_edge_boot_label(theme$mm.edge.boot.template, letter,
loading, tvalue, pvalue, stars, civalue)
} else {
edge_label <- ""
}
edge_style <-
get_value_dependent_mm_edge_style(loading, theme)
if(is_sink(model,index)) {
source_node <- mm_matrix_subset[i, 1]
target_node <- mm_matrix_subset[i, 2]
} else {
# TODO flip edges
source_node <- mm_matrix_subset[i, 2]
target_node <- mm_matrix_subset[i, 1]
}
# append edge
edges <- paste0(
edges,
"\"",
source_node,
"\" -> {\"",
target_node,
"\"}",
"[weight = ",
weights,
edge_label,
", penwidth = ",
abs(loading * theme$mm.edge.width_multiplier) + theme$mm.edge.width_offset,
edge_style,
"]\n"
)
}
return(edges)
}
#' Formats the style of the structural model edges
#'
#' @param value value to compare for negativity
#' @param theme the theme to use
#'
#' @return Returns the style for the edge (both style and color)
get_value_dependent_mm_edge_style <- function(value, theme){
edge_style <- paste0(", style = ", theme$mm.edge.positive.style,
", color = ", theme$mm.edge.positive.color)
if (value < 0) {
edge_style <- paste0(", style = ", theme$mm.edge.negative.style,
", color = ", theme$mm.edge.negative.color)
}
edge_style
}
# END ----
# ___________________ ----
# EXPERIMENTAL STUFF ----
hyperedge <- function(){
dot <- "digraph {
A [label = IV]
B [label = DV]
C [label = Moderator]
empty [label = '', shape = point, width = 0, height = 0]
A -> empty [arrowhead = none, weight = 1000, headlabel = <<BR/>test>]
empty -> B [weight = 1000]
C -> empty [constraint = FALSE]
C -> B
}
"
#DiagrammeR::grViz(dot)
}
# Font things
dot <- "digraph {
A [label = IV]
B [label = DV]
A -> B [label = < <FONT POINT-SIZE='20'> <B><I>lamda</I> = 0.3</B></FONT> <BR /> <I>p</I> < 0.001 >]
}"
#DiagrammeR::grViz(dot)
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.