################################################################################
#
# Plotting:
#
# Plotting is handled by a single function that can manage CMA0, CMA1+ as well
# as per-episodes and sliding-windows.
# It can handle 1 or more patients.
#
# For a given case, it produces an intermediate format that can be used to
# generate either a static plot (using R base graphics) or various degrees of
# interactivity (using HTML5/CSS/JavaScript).
#
# In principle, this should ensure the "future-proffing" of the plotting system
# as well as make its maintenance and development easier by providing a unified
# codebase.
#
# This is part of AdhereR.
#
# Copyright (C) 2015-2018 Dan Dediu & Alexandra Dima
# Copyright (C) 2018-2019 Dan Dediu, Alexandra Dima & Samuel Allemann
#
# This program is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 3 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program. If not, see <http://www.gnu.org/licenses/>.
#
################################################################################
## TODO ####
#
# string height & width in SVG
# make sure the image resizes well
# check colors, etc, consistency
# image dimensions (also for export)
#
# HTML + CSS + JavaScript
#
# test
# profile & optimise
#
# Grayscale colors palette:
.bw.colors <- function(n)
{
gray.colors(n, start=0, end=0.5);
}
## SVG special functions and constants ####
.SVG.number <- function(n, prec=3)
{
# if( is.numeric(n) ) as.character(round(n,prec)) else n;
if( is.numeric(n) ) sprintf("%.3f",n) else n;
}
# Replace special characters with XML/HTML entities
# Inspired by htmlspecialchars() in package "fun"
# and HTMLdecode()/HTMLencode() in package "textutils"
.SVG.specialchars.2.XMLentities <- function(s)
{
s <- as.character(s); # make sure s is a string
spec.chars <- c("&"="&",
"""='"',
"'"="'",
"<"="<",
">"=">");
if( length(grep("[&\\+\"'<>]", s, fixed=FALSE)) == 0 ) return (s); # none found
# Replace them with the corresponding HTML entities:
for (i in seq_along(spec.chars))
{
s <- gsub(spec.chars[i], names(spec.chars)[i], s, fixed = TRUE);
}
return (s);
}
.SVG.comment <- function(s,
newpara=FALSE, # should there be a newline before the comment?
newline=TRUE, # should a newline be added at the end?
return_string=FALSE # return a singe string or a vector of strings to be concatenated later?
)
{
r <- c(if(newpara) '\n',
'<!-- ',s,' -->',
if(newline) '\n');
if( return_string ) return (paste0(r,collapse="")) else return (r);
}
.SVG.color <- function(col,
return_string=FALSE)
{
if( col == "none" )
{
return ('none');
} else
{
if( return_string )
{
return (paste0("rgb(",paste0(col2rgb(col),collapse=","),")"));
} else
{
x <- col2rgb(col);
return (list('rgb(', x[1], ',', x[2], ',', x[3], ')'));
}
}
}
# Stroke dash-arrays for line types (lty):
.SVG.lty <- data.frame("lty"=0:6,
"names"=c("blank", "solid", "dashed", "dotted", "dotdash", "longdash", "twodash"),
"stroke"=c("none", NA, NA, NA, NA, NA, NA),
"stroke-dasharray"=c(NA, NA, "3,3", "1,2", "1,2,3,2", "5,2", "2,2,4,2"),
stringsAsFactors=FALSE);
.SVG.rect <- function(x=NA, y=NA, width=NA, height=NA, xend=NA, yend=NA, # can accomodate both (wdith,height) and (xend,yend)
stroke=NA, stroke_width=NA, lty=NA, stroke_dasharray=NA, fill="white", fill_opacity=NA, other_params=NA, # styling attributes
id=NA, class=NA, comment=NA, tooltip=NA, # ID, comment and tooltip
newline=TRUE, # should a newline be added at the end?
return_string=FALSE # return a singe string or a vector of strings to be concatenated later?
)
{
# Check for missing data:
if( is.na(x) || is.na(y) || (is.na(width) && is.na(xend)) || (is.na(height) && is.na(yend)) )
{
# Nothing to plot!
if( return_string ) return ("") else return (NULL);
}
if(!is.na(tooltip)) tooltip <- .SVG.specialchars.2.XMLentities(tooltip); # make sure special chars in tooltip are treated correctly
# Process lty first:
if( !is.na(lty) )
{
if( is.numeric(lty) ) s <- which(.SVG.lty$lty == lty) else s <- which(.SVG.lty$names == as.character(lty));
if( length(s) == 1 )
{
if( !is.na(.SVG.lty$stroke[s]) ) stroke <- .SVG.lty$stroke[s];
stroke_dasharray <- .SVG.lty$stroke.dasharray[s];
}
}
r <- list(# The initial comment (if any):
if(!is.na(comment)) .SVG.comment(comment),
# The rect element:
'<rect ',
# The id and class (if any):
if(!is.na(id)) c('id="',id,'" '),
if(!is.na(class)) c('class="',class,'" '),
# The x and y coordinates of the bottom-left corner:
if(!is.na(x)) c('x="',.SVG.number(x),'" '),
if(!is.na(y)) c('y="',.SVG.number(y),'" '),
# The width and height of the rectangle (either given directly or computed from the top-right corner coordinates):
if(!is.na(width)) c('width="', .SVG.number(width), '" ') else if(!is.na(xend)) c('width="',.SVG.number(xend-x),'" '),
if(!is.na(height)) c('height="',.SVG.number(height),'" ') else if(!is.na(yend)) c('height="',.SVG.number(yend-y),'" '),
# Aesthetics:
if(!is.na(stroke)) c('stroke="', .SVG.color(stroke), '" '),
if(!is.na(stroke_width)) c('stroke-width="',stroke_width,'" '),
if(!is.na(stroke_dasharray)) c('stroke-dasharray="',stroke_dasharray,'" '),
if(!is.na(fill)) c('fill="', .SVG.color(fill), '" '),
if(!is.na(fill_opacity)) c('fill-opacity="',fill_opacity,'" '),
# Other parameters:
if(!is.na(other_params)) other_params,
# Close the element (and add optional tooltip):
if(!is.na(tooltip)) c('>',' <title>', tooltip, '</title>', '</rect>') else '></rect>', # the tooltip title must be first child
# Add ending newline (if so required):
if(newline) '\n'
);
if( return_string ) return (paste0(unlist(r),collapse="")) else return (r);
}
.SVG.lines <- function(x, y, # the coordinates of the points (at least 2)
connected=FALSE, # are the lines connected or not?
stroke=NA, stroke_width=NA, lty=NA, stroke_dasharray=NA, other_params=NA, # styling attributes (may be one per line for connected==FALSE)
id=NA, class=NA, comment=NA, tooltip=NA, # ID, comment and tooltip
newline=TRUE, # should a newline be added at the end?
return_string=FALSE, # return a singe string or a vector of strings to be concatenated later?
suppress.warnings=FALSE
)
{
# Preconditions:
if( length(x) != length(y) || length(x) < 2 || length(y) < 2 )
{
if( !suppress.warnings ) .report.ewms("The line point coodinates must be of the same length >= 2.\n", "error", ".SVG.lines", "AdhereR");
if( return_string ) return ("") else return (NULL);
}
if(!is.na(tooltip)) tooltip <- .SVG.specialchars.2.XMLentities(tooltip); # make sure special chars in tooltip are treated correctly
if(connected)
{
# One 'polyline' elememet:
# Process lty:
if( length(lty) > 0 && !is.na(lty) )
{
lty.cur <- lty[1]; # consider only the first one
if( is.numeric(lty.cur) ) s <- which(.SVG.lty$lty == lty.cur) else s <- which(.SVG.lty$names == as.character(lty.cur));
if( length(s) == 1 )
{
if( !is.na(.SVG.lty$stroke[s]) ) stroke <- .SVG.lty$stroke[s];
stroke_dasharray <- .SVG.lty$stroke.dasharray[s];
}
}
# Remove any points with NA coordinates:
s <- (!is.na(x) & !is.na(y));
if( !any(s) )
{
# Nothing to plot:
if( return_string ) return ("") else return (NULL);
}
x <- x[s]; y <- y[s]; # Keep only the non-missing points
# Pre-process stroke:
if(!is.na(stroke)) stroke2col <- .SVG.color(stroke);
r <- list(# The initial comment (if any):
if(!is.na(comment)) .SVG.comment(comment),
'<polyline ',
# The id and class (if any):
if(!is.na(id)) c('id="',id,'" '),
if(!is.na(class)) c('class="',class,'" '),
# The coordinates of the points as pairs separated by ',':
'points="', unlist(lapply(seq_along(x), function(i) c(.SVG.number(x[i]),",",.SVG.number(y[i])," "))),'" ',
# Aesthetics:
'fill="none" ',
if(!is.na(stroke)) c('stroke="', stroke2col, '" '),
if(!is.na(stroke_width)) c('stroke-width="',stroke_width,'" '),
if(!is.na(stroke_dasharray)) c('stroke-dasharray="',stroke_dasharray,'" '),
# Other parameters:
if(!is.na(other_params)) other_params,
# Close the element (and add optional tooltip):
if(!is.na(tooltip)) c('>',' <title>', tooltip, '</title>', '</polyline>') else '></polyline>', # the tooltip title must be first child
# Add ending newline (if so required):
if(newline) '\n'
);
} else
{
# Multiple 'line' elements:
if( length(x) %% 2 != 0 )
{
if( !suppress.warnings ) .report.ewms("For unconnected lines there must an even number of point coordinates.\n", "error", ".SVG.lines", "AdhereR");
return (NULL);
}
r <- list(# The initial comment (if any):
if(!is.na(comment)) .SVG.comment(comment),
lapply(seq(1,length(x),by=2), function(i)
{
# Check for missing coordinates:
if( is.na(x[i]) || is.na(x[i+1]) || is.na(y[i]) || is.na(y[i+1]) ) return(NULL); # cannot draw this line
# Process lty:
if( length(lty) > 0 && all(!is.na(lty)) )
{
if( length(lty) == length(x)/2 ) lty.cur <- lty[(i+1)/2] else lty.cur <- lty[1]; # consider the corresponding lty or only first one
if( is.numeric(lty.cur) ) s <- which(.SVG.lty$lty == lty.cur) else s <- which(.SVG.lty$names == as.character(lty.cur));
if( length(s) == 1 )
{
if( !is.na(.SVG.lty$stroke[s]) ) stroke <- .SVG.lty$stroke[s];
stroke_dasharray <- .SVG.lty$stroke.dasharray[s];
}
}
list('<line ',
# The id and class (if any):
if(!is.na(id)) c('id="',id,'" '),
if(!is.na(class)) c('class="',class,'" '),
# The coordinates of the points:
'x1="', .SVG.number(x[i]), '" ',
'y1="', .SVG.number(y[i]), '" ',
'x2="', .SVG.number(x[i+1]), '" ',
'y2="', .SVG.number(y[i+1]), '" ',
# Aesthetics:
if(!is.na(stroke)) c('stroke="', .SVG.color(stroke), '" '),
if(!is.na(stroke_width)) c('stroke-width="',stroke_width,'" '),
if(!is.na(stroke_dasharray)) c('stroke-dasharray="',stroke_dasharray,'" '),
# Other parameters:
if(!is.na(other_params)) other_params,
# Close the element (and add optional tooltip):
if(!is.na(tooltip)) c('>',' <title>', tooltip, '</title>', '</line>') else '></line>', # the tooltip title must be first child
# Add ending newline (if so required):
if(newline) '\n'
);
}));
}
if( return_string ) return (paste0(unlist(r),collapse="")) else return (r);
}
.SVG.points <- function(x, y, pch=0,
col="black", cex=1.0, other_params=NA, # styling attributes
id=NA, class=NA, comment=NA, tooltip=NA, # ID, comment and tooltip
newline=TRUE, # should a newline be added at the end?
return_string=FALSE, # return a singe string or a vector of strings to be concatenated later?
suppress.warnings=FALSE
)
{
# Preconditions:
if( length(x) != length(y) || length(x) == 0 )
{
if( !suppress.warnings ) .report.ewms("There must be at least on point.\n", "error", ".SVG.points", "AdhereR");
return (NULL);
}
if(!is.na(tooltip)) tooltip <- .SVG.specialchars.2.XMLentities(tooltip); # make sure special chars in tooltip are treated correctly
# Make sure the point attributes are correctly distributed:
if( length(pch) != length(x) ) pch <- rep(pch[1], length(x));
if( length(col) != length(x) )
{
col <- rep(col[1], length(x));
col_cache <- rep(.SVG.color(col[1]), length(x));
} else
{
col_cache <- lapply(col, function(z) .SVG.color(z));
}
if( length(cex) != length(x) ) cex <- rep(cex[1], length(x));
# Remove any points with NA coordinates:
s <- (!is.na(x) & !is.na(y) & !is.na(pch));
if( !any(s) )
{
# Nothing to plot:
if( return_string ) return ("") else return (NULL);
}
x <- x[s]; y <- y[s]; pch <- pch[s]; col <- col[s]; cex <- cex[s]; # Keep only the non-missing points
r <- list(# The initial comment (if any):
if(!is.na(comment)) .SVG.comment(comment),
lapply(seq_along(x), function(i)
{
list(# The element:
'<g ',
# The id and class (if any):
if(!is.na(id)) c('id="',id,'" '),
if(!is.na(class)) c('class="',class,'" '),
'>',
# Add optional tooltip:
if(!is.na(tooltip)) c(' <title>', tooltip, '</title>'), # the tooltip title must be first child
# Reuse the predefined symbol:
'<use xlink:href="#pch',pch[i],'" ',
# The coordinates and size:
'transform="translate(',.SVG.number(x[i]),' ',.SVG.number(y[i]),') scale(',cex[i],')" ',
# Aesthetics:
if(!is.na(col[i])) list('stroke="', col_cache[[i]], '" ', 'fill="', col_cache[[i]], '" '),
# Other parameters:
if(!is.na(other_params)) other_params,
# Close the element:
'></use></g>',
# Add ending newline (if so required):
if(newline) '\n'
);
}));
if( return_string ) return (paste0(unlist(r),collapse="")) else return (r);
}
.SVG.text <- function(x, y, text,
col="black", font="Arial", font_size=16,
h.align=c(NA,"left","center","right")[1], v.align=c(NA,"top","center","bottom")[1], # alignment
rotate=NA, # rotation in degrees
other_params=NA, # styling attributes
id=NA, class=NA, comment=NA, tooltip=NA, # ID, comment and tooltip
newline=TRUE, # should a newline be added at the end?
return_string=FALSE, # return a singe string or a vector of strings to be concatenated later?
suppress.warnings=FALSE
)
{
# Preconditions:
if( length(x) != length(y) || length(x) != length(text) || length(x) == 0 )
{
if( !suppress.warnings ) .report.ewms("There must be at least one text and the number of texts should matche the number of coordinates.\n", "error", ".SVG.text", "AdhereR");
return (NULL);
}
if(!is.na(tooltip)) tooltip <- .SVG.specialchars.2.XMLentities(tooltip); # make sure special chars in tooltip are treated correctly
# Make sure the attributes are correctly distributed:
if( length(col) != length(x) ) col <- rep(col[1], length(x));
if( length(font) != length(x) ) font <- rep(font[1], length(x));
if( length(font_size) != length(x) ) font_size <- rep(font_size[1], length(x));
if( length(h.align) != length(x) ) h.align <- rep(h.align[1], length(x));
if( length(v.align) != length(x) ) v.align <- rep(v.align[1], length(x));
if( length(rotate) != length(x) ) rotate <- rep(rotate[1], length(x));
# Remove any points with NA coordinates:
s <- (!is.na(x) & !is.na(y) & !is.na(text));
if( !any(s) )
{
# Nothing to plot:
if( return_string ) return ("") else return (NULL);
}
x <- x[s]; y <- y[s]; col <- col[s]; font <- font[s]; font_size <- font_size[s]; h.align <- h.align[s]; v.align <- v.align[s]; rotate <- rotate[s]; # Keep only the non-missing points
r <- list(# The initial comment (if any):
if(!is.na(comment)) .SVG.comment(comment),
lapply(seq_along(x), function(i)
{
list(# The element:
'<text ',
# The id and class (if any):
if(!is.na(id)) c('id="',id,'" '),
if(!is.na(class)) c('class="',class,'" '),
# The coordinates:
'x="',.SVG.number(x[i]),'" y="',.SVG.number(y[i]),'" ',
# The font:
'font-family="',font[i],'" font-size="',font_size[i],'" ',
# The alignment:
if(!is.na(h.align[i])) c('text-anchor="',switch(h.align[i], "left"="start", "center"="middle", "right"="end"),'" '),
#if(!is.na(v.align[i])) c('alignment-baseline="',switch(v.align[i], "top"="auto", "center"="central", "bottom"="baseline"),'" '),
if(!is.na(v.align[i]) && v.align[i]!="top") c('dominant-baseline="',switch(v.align[i], "center"="central", "bottom"="text-before-edge"),'" '),
# Rotation:
if(!is.na(rotate[i])) c('transform="rotate(',rotate[i],' ',.SVG.number(x[i]),' ',.SVG.number(y[i]),')" '),
# Aesthetics:
if(!is.na(col[i])) c('fill="', .SVG.color(col[i]), '" '),
# Other parameters:
if(!is.na(other_params)) other_params,
# Close the tag:
'> ',
# The text:
.SVG.specialchars.2.XMLentities(text[i]),
# Add optional tooltip:
if(!is.na(tooltip)) c(' <title>', tooltip, '</title>'), # the tooltip title must be first child
# Close it:
'</text>',
# Add ending newline (if so required):
if(newline) '\n'
);
}));
if( return_string ) return (paste0(unlist(r),collapse="")) else return (r);
}
# For a given font, style, font size and cex, compute the string's width and height in pixels
# family cam be "serif", "sans" or "mono"; font can be 1 = plain text, 2 = bold face, 3 = italic and 4 = bold italic; font_size in pixels; cex as for points
.SVG.string.dims <- function(s, family="sans", font=1, font_size=10, cex=1.0)
{
# Actual font size:
font_size_cex <- (font_size * cex);
# The number of lines of text:
no.lines <- length(grep("\n",s,fixed=TRUE)) + 1;
## The stupid way:
#return (c("width"=(nchar(s) - no.lines + 1) * font_size_cex,
# "height"=no.lines * font_size_cex));
# Slightly better way: use "M" as the reference and compute everything relative to it (use the ):
M.h <- strheight("M",units="inches"); M.w <- strwidth("M",units="inches");
s.h <- strheight(s,units="inches"); s.w <- strwidth(s,units="inches");
return (c("width"=(s.w / M.w) * font_size_cex,
"height"=(s.h / M.h) * font_size_cex));
}
#' Access last adherence plot info.
#'
#' Returns the full info the last adherence plot, to be used to modify and/or to
#' add new elements to this plot.
#'
#' This is intended for advanced users only.
#' It may return \code{NULL} if no plotting was generated yet, but if one was, a
#' list contaning one named element for each type of plot produced (currently only
#' \emph{baseR} and \emph{SVG} are used).
#' For all types of plots there are a set of \emph{mapping} functions useful for
#' transforming events in plotting coordinates: \code{.map.event.x(x)} takes a
#' number of days \code{x}, \code{.map.event.date(d, adjust.for.earliest.date=TRUE)}
#' takes a \code{Date} \code{d} (and implictely adjusts for the earilerst date
#' plotted), and \code{.map.event.y(y)} takes a row ("event" number) \code{y}.
#' Besides the shared elements (see the returned value), there are specific ones
#' as well.
#' For \emph{baseR}, the members \emph{old.par} and \emph{used.par} contain the
#' original (pre-plot) \code{par()} environment and the one used within
#' \code{plot()}, respectively, in case these need restoring.
#'
#' @return A \code{list} (possibly empty) contaning one named element for each type
#' of plot produced (currently only \emph{baseR} and \emph{SVG}). Each may contain
#' shared and specific fields concerning:
#' \itemize{
#' \item the values of the parameters with which \code{plot()} was invoked.
#' \item actual plot size and other characteristics.
#' \item actual title, axis names and labels and their position and size.
#' \item legend size, position and size and position of its components.
#' \item expanded \code{cma$data} contaning, for each event, info about its
#' plotting, including the corresponding fullow-uo and observation windows,
#' event start and end, dose text (if any) and other graphical elements.
#' \item position, size of the partial CMAs (if any) and of their components.
#' \item position, size of the plotted CMAs (if any) and of their components.
#' \item rescaling function(s) useful for mapping events to plotting coordinates.
#' }
#' @examples
#' cma7 <- CMA7(data=med.events[med.events$PATIENT_ID %in% c(1,2),],
#' ID.colname="PATIENT_ID",
#' event.date.colname="DATE",
#' event.duration.colname="DURATION",
#' event.daily.dose.colname="PERDAY",
#' medication.class.colname="CATEGORY",
#' followup.window.start=0,
#' followup.window.start.unit="days",
#' followup.window.duration=2*365,
#' followup.window.duration.unit="days",
#' observation.window.start=30,
#' observation.window.start.unit="days",
#' observation.window.duration=365,
#' observation.window.duration.unit="days",
#' date.format="%m/%d/%Y",
#' summary="Base CMA");
#' plot(cma7);
#' tmp <- last.plot.get.info();
#' names(tmp);
#' tmp$baseR$legend$box; # legend position and size
#' head(tmp$baseR$cma$data); # events + plotting info
#' # Add a transparent blue rect between days 270 and 900:
#' rect(tmp$baseR$.map.event.x(270), tmp$baseR$.map.event.y(1-0.5),
#' tmp$baseR$.map.event.x(900), tmp$baseR$.map.event.y(nrow(tmp$baseR$cma$data)+0.5),
#' col=adjustcolor("blue",alpha.f=0.5), border="blue");
#' # Add a transparent rect rect between dates 03/15/2036 and 03/15/2037:
#' rect(tmp$baseR$.map.event.date(as.Date("03/15/2036", format="%m/%d/%Y")),
#' tmp$baseR$.map.event.y(1-0.5),
#' tmp$baseR$.map.event.date(as.Date("03/15/2037", format="%m/%d/%Y")),
#' tmp$baseR$.map.event.y(nrow(tmp$baseR$cma$data)+0.5),
#' col=adjustcolor("red",alpha.f=0.5), border="blue");
#' @export
last.plot.get.info <- function() { return (get(".last.cma.plot.info", envir=.adherer.env)); }
#' Map from event to plot coordinates.
#'
#' Maps the (x,y) coordinates in the event space to the plotting space.
#'
#' This is intended for advanced users only.
#' In the event space, the \emph{x} coordinate can be either given as the number of
#' days since the first plotted event, or as an actual calendar date (either as a
#' \code{Date} object or a string with a given format; a date may or may not be corrected
#' relative to the first displayed date). On the \emph{y} coordinate, the plotting is
#' divided in equally spaced rows, each row corresponding to a single event or an element
#' of a partial CMA plot (one can specify in between rows using fractions). Any or both of
#' \emph{x} and \emph{y} can be missing.
#'
#' @param x The \emph{x} coordinate in the event space, either a \code{number} giving the
#' number of days since the earliest plotted date, or a \code{Date} or a \code{string} in
#' the format given by the \emph{x.date.format} parameter giving the actual calendar date.
#' @param y The \emph{y} coordinate in the event space, thus a \code{number} giving the
#' plot row.
#' @param x.is.Date A \code{logical}, being \code{TRUE} if \emph{x} is a string giving the
#' date in the \emph{x.date.format} format.
#' @param x.date.format A \code{string} giving the format of the \emph{x} date, if
#' \emph{x.is.Date} id \code{TRUE}.
#' @param adjust.for.earliest.date A \code{logical} which is \code{TRUE} if \emph{x} is a
#' calendar date that must be adjusted for the earliest plotted date (by default
#' \code{TRUE}).
#' @param plot.type Can be either "baseR" or "SVG" and specifies to which type of plotting
#' the mapping applies.
#' @param suppress.warnings \emph{Logical}, if \code{TRUE} don't show any
#' warnings.
#'
#' @return A numeric vector with \emph{x} and \emph{y} components giving the plotting
#' coordinates, or \code{NULL} in case of error.
#'
#' @examples
#' cma7 <- CMA7(data=med.events[med.events$PATIENT_ID %in% c(1,2),],
#' ID.colname="PATIENT_ID",
#' event.date.colname="DATE",
#' event.duration.colname="DURATION",
#' event.daily.dose.colname="PERDAY",
#' medication.class.colname="CATEGORY",
#' followup.window.start=0,
#' followup.window.start.unit="days",
#' followup.window.duration=2*365,
#' followup.window.duration.unit="days",
#' observation.window.start=30,
#' observation.window.start.unit="days",
#' observation.window.duration=365,
#' observation.window.duration.unit="days",
#' date.format="%m/%d/%Y",
#' summary="Base CMA");
#' plot(cma7);
#' # Add a transparent blue rect:
#' rect(map.event.coords.to.plot(x=270),
#' get.event.plotting.area()["y.min"]-1,
#' map.event.coords.to.plot(x="03/15/2037", x.is.Date=TRUE, x.date.format="%m/%d/%Y"),
#' get.event.plotting.area()["y.max"]+1,
#' col=adjustcolor("blue",alpha.f=0.5), border="blue");
#' @export
map.event.coords.to.plot <- function(x=NA, y=NA, x.is.Date=FALSE, x.date.format="%m/%d/%Y", adjust.for.earliest.date=TRUE, plot.type=c("baseR", "SVG")[1], suppress.warnings=FALSE)
{
lcpi <- last.plot.get.info();
if( plot.type[1] == "baseR" )
{
if( is.null(lcpi) || is.null(lcpi$baseR) )
{
if( !suppress.warnings ) .report.ewms("No CMA plot or no base R plot were generated!\n", "error", "map.event.coords.to.plot", "AdhereR");
return (NULL);
} else
{
# x:
if( is.na(x) )
{
x1 <- NA;
} else if( inherits(x, "Date") )
{
x1 <- lcpi$baseR$.map.event.date(x, adjust.for.earliest.date=adjust.for.earliest.date);
} else if( x.is.Date )
{
x1 <- lcpi$baseR$.map.event.date(as.Date(as.character(x), format=x.date.format), adjust.for.earliest.date=adjust.for.earliest.date);
} else
{
x1 <- lcpi$baseR$.map.event.x(x);
}
# y:
if( is.na(y) )
{
y1 <- NA;
} else
{
y1 <- lcpi$baseR$.map.event.y(y);
}
# Return value:
return (c("x"=x1, "y"=y1));
}
} else if( plot.type[1] == "SVG" )
{
if( is.null(lcpi) || is.null(lcpi$SVG) )
{
if( !suppress.warnings ) .report.ewms("No CMA plot or no SVG was generated!\n", "error", "map.event.coords.to.plot", "AdhereR");
return (NULL);
} else
{
# x:
if( inherits(x, "Date") || x.is.Date )
{
x1 <- lcpi$SVG$.map.event.date(ifelse(inherits(x, "Date"), x, as.Date(x, format=x.date.format)), adjust.for.earliest.date=adjust.for.earliest.date);
} else
{
x1 <- lcpi$SVG$.map.event.x(x);
}
# y:
y1 <- lcpi$SVG$.map.event.y(y);
# Return value:
return (c("x"=x1, "y"=y1));
}
} else
{
if( !suppress.warnings ) .report.ewms("Unknown plot type!\n", "error", "map.event.coords.to.plot", "AdhereR");
return (NULL);
}
}
#' Get the actual plotting area.
#'
#' Returns the actual plotting area rectangle in plotting coordinates.
#'
#' This is intended for advanced users only.
#'
#' @param plot.type Can be either "baseR" or "SVG" and specifies to which type of plotting
#' the mapping applies.
#' @param suppress.warnings \emph{Logical}, if \code{TRUE} don't show any
#' warnings.
#'
#' @return A numeric vector with components \emph{x.min}, \emph{x.max},
#' \emph{y.min} and \emph{y.max}, or \code{NULL} in case of error.
#' @export
get.event.plotting.area <- function(plot.type=c("baseR", "SVG")[1], suppress.warnings=FALSE)
{
lcpi <- last.plot.get.info();
if( plot.type[1] == "baseR" )
{
if( is.null(lcpi) || is.null(lcpi$baseR) )
{
if( !suppress.warnings ) .report.ewms("No CMA plot or no base R was generated!\n", "error", "get.event.plotting.area", "AdhereR");
return (NULL);
} else
{
return (c("x.min"=lcpi$baseR$x.min, "x.max"=lcpi$baseR$x.max, "y.min"=lcpi$baseR$y.min, "y.max"=lcpi$baseR$y.max));
}
} else if( plot.type[1] == "SVG" )
{
if( is.null(lcpi) || is.null(lcpi$SVG) )
{
if( !suppress.warnings ) .report.ewms("No CMA plot or no SVG was generated!\n", "error", "get.event.plotting.area", "AdhereR");
return (NULL);
} else
{
return (c("x.min"=lcpi$SVG$x.min, "x.max"=lcpi$SVG$x.max, "y.min"=lcpi$SVG$y.min, "y.max"=lcpi$SVG$y.max));
}
} else
{
if( !suppress.warnings ) .report.ewms("Unknown plot type!\n", "error", "get.event.plotting.area", "AdhereR");
return (NULL);
}
}
#' Get the legend plotting area.
#'
#' Returns the legend plotting area rectangle in plotting coordinates
#' (if any).
#'
#' This is intended for advanced users only.
#'
#' @param plot.type Can be either "baseR" or "SVG" and specifies to which type of plotting
#' the mapping applies.
#' @param suppress.warnings \emph{Logical}, if \code{TRUE} don't show any
#' warnings.
#'
#' @return A numeric vector with components \emph{x.min}, \emph{x.max},
#' \emph{y.min} and \emph{y.max}, or \code{NULL} in case of error or no
#' legend being shown.
#' @export
get.legend.plotting.area <- function(plot.type=c("baseR", "SVG")[1], suppress.warnings=FALSE)
{
lcpi <- last.plot.get.info();
if( plot.type[1] == "baseR" )
{
if( is.null(lcpi) || is.null(lcpi$baseR) )
{
if( !suppress.warnings ) .report.ewms("No CMA plot or no base R was generated!\n", "error", "get.legend.plotting.area", "AdhereR");
return (NULL);
} else
{
if( is.null(lcpi$baseR$legend$box) )
{
return (NULL); # no legend being shown
} else
{
return (c("x.min"=lcpi$baseR$legend$box$x.start, "x.max"=lcpi$baseR$legend$box$x.end, "y.min"=lcpi$baseR$legend$box$y.start, "y.max"=lcpi$baseR$legend$box$y.end));
}
}
} else if( plot.type[1] == "SVG" )
{
if( is.null(lcpi) || is.null(lcpi$SVG) )
{
if( !suppress.warnings ) .report.ewms("No CMA plot or no SVG was generated!\n", "error", "get.legend.plotting.area", "AdhereR");
return (NULL);
} else
{
if( is.null(lcpi$SVG$legend$box) )
{
return (NULL); # no legend being shown
} else
{
return (c("x.min"=lcpi$SVG$legend$box$x.start, "x.max"=lcpi$SVG$legend$box$x.end, "y.min"=lcpi$SVG$legend$box$y.start, "y.max"=lcpi$SVG$legend$box$y.end));
}
}
} else
{
if( !suppress.warnings ) .report.ewms("Unknown plot type!\n", "error", "get.legend.plotting.area", "AdhereR");
return (NULL);
}
}
#' Get info about the plotted events.
#'
#' Returns a \code{data.frame} where each row contains info about one plotted event;
#' the order of the rows reflects the y-axis (first row on bottom).
#'
#' This is intended for advanced users only.
#'
#' @param plot.type Can be either "baseR" or "SVG" and specifies to which type of plotting
#' the mapping applies.
#' @param suppress.warnings \emph{Logical}, if \code{TRUE} don't show any
#' warnings.
#'
#' @return A \code{data.frame} that, besides the info about each event, also
#' contains info about:
#' \itemize{
#' \item the corresponding follow-up and observation windows (and, for
#' \code{CMA8}, the "real" observation window), given as the corners of the area
#' \emph{.X...START}, \emph{.X...END}, \emph{.Y...START} and \emph{.Y...END}
#' (where the mid dot stands for FUW, OW and ROW, respectively).
#' \item the area occupied by the graphic representation of the event given by
#' its four corners \emph{.X.START}, \emph{.X.END}, \emph{.Y.START} and
#' \emph{.Y.END}, as well as the line width \emph{.EV.LWD}.
#' \item the dose text's (if any) position (\emph{.X.DOSE}, \emph{.Y.DOSE}) and
#' font size \emph{.FONT.SIZE.DOSE}.
#' \item if event corvered and not covered are plotted, also give their areas as
#' \emph{.X.EVC.START}, \emph{.X.EVC.END}, \emph{.Y.EVC.START}, \emph{.Y.EVC.END},
#' \emph{.X.EVNC.START}, \emph{.X.EVNC.END}, \emph{.Y.EVNC.START} and
#' \emph{.Y.EVNC.END}.
#' \item the continuation lines area as \emph{.X.CNT.START}, \emph{.X.CNT.END},
#' \emph{.Y.CNT.START} and \emph{.Y.CNT.END}.
#' \item and the corresponding summary CMA (if any) given as the area
#' \emph{.X.SCMA.START}, \emph{.X.SCMA.END}, \emph{.Y.SCMA.START} and
#' \emph{.Y.SCMA.END}.
#' }
#' Please note that even if with follow-up and ("real") observation window, and
#' the summary CMA info is repeated for each event, they really make sense at
#' the level of the patient.
#' @examples
#' cma7 <- CMA7(data=med.events[med.events$PATIENT_ID %in% c(1,2),],
#' ID.colname="PATIENT_ID",
#' event.date.colname="DATE",
#' event.duration.colname="DURATION",
#' event.daily.dose.colname="PERDAY",
#' medication.class.colname="CATEGORY",
#' followup.window.start=0,
#' followup.window.start.unit="days",
#' followup.window.duration=2*365,
#' followup.window.duration.unit="days",
#' observation.window.start=30,
#' observation.window.start.unit="days",
#' observation.window.duration=365,
#' observation.window.duration.unit="days",
#' date.format="%m/%d/%Y",
#' summary="Base CMA");
#' plot(cma7);
#' tmp <- get.plotted.events();
#' head(tmp);
#' # "Mask" the first event:
#' rect(tmp$.X.START[1], tmp$.Y.START[1]-0.5, tmp$.X.END[1], tmp$.Y.END[1]+0.5,
#' col=adjustcolor("white",alpha.f=0.75), border="black");
#' # "Mask" the first patient's summary CMA:
#' rect(tmp$.X.SCMA.START[1], tmp$.Y.SCMA.START[1],
#' tmp$.X.SCMA.END[1], tmp$.Y.SCMA.END[1],
#' col=adjustcolor("white",alpha.f=0.75), border="black");
#' @export
get.plotted.events <- function(plot.type=c("baseR", "SVG")[1], suppress.warnings=FALSE)
{
lcpi <- last.plot.get.info();
if( plot.type[1] == "baseR" )
{
if( is.null(lcpi) || is.null(lcpi$baseR) )
{
if( !suppress.warnings ) .report.ewms("No CMA plot or no base R was generated!\n", "error", "get.plotted.events", "AdhereR");
return (NULL);
} else
{
if( is.null(lcpi$baseR$cma) || is.null(lcpi$baseR$cma$data) )
{
if( !suppress.warnings ) .report.ewms("No info about the plotted CMA!\n", "error", "get.plotted.events", "AdhereR");
return (NULL);
} else
{
return (lcpi$baseR$cma$data);
}
}
} else if( plot.type[1] == "SVG" )
{
if( is.null(lcpi) || is.null(lcpi$SVG) )
{
if( !suppress.warnings ) .report.ewms("No CMA plot or no SVG was generated!\n", "error", "get.plotted.events", "AdhereR");
return (NULL);
} else
{
if( is.null(lcpi$SVG$cma) || is.null(lcpi$SVG$cma$data) )
{
if( !suppress.warnings ) .report.ewms("No info about the plotted CMA!\n", "error", "get.plotted.events", "AdhereR");
return (NULL);
} else
{
return (lcpi$SVG$cma$data);
}
}
} else
{
if( !suppress.warnings ) .report.ewms("Unknown plot type!\n", "error", "get.plotted.events", "AdhereR");
return (NULL);
}
}
#' Get info about the plotted partial CMAs.
#'
#' Returns a \code{data.frame} where each row contains info about one plotted
#' partial CMA (partial CMAs make sense only for "complex" CMAs, i.e., per
#' episode and sliding windows).
#'
#' This is intended for advanced users only.
#'
#' @param plot.type Can be either "baseR" or "SVG" and specifies to which type of plotting
#' the mapping applies.
#' @param suppress.warnings \emph{Logical}, if \code{TRUE} don't show any
#' warnings.
#'
#' @return A \code{data.frame} that contains info about:
#' \itemize{
#' \item the patient ID (\emph{pid}) to which the partial CMA belongs.
#' \item the \emph{type} of partial CMA (see the help for plotting "complex"
#' CMAs).
#' \item the corners of the whole area covered by the partial CMA plot given as
#' \emph{x.region.start}, \emph{y.region.start}, \emph{x.region.end} and
#' \emph{y.region.end}.
#' \item for each element of the partial CMA plot, its area as
#' \emph{x.partial.start}, \emph{y.partial.start}, \emph{x.partial.end} and
#' \emph{y.partial.end}.
#' }
#' Please note that this contains one row per partial CMA element (e.g., if
#' plotting stacked, one row for each rectangle).
#' @export
get.plotted.partial.cmas <- function(plot.type=c("baseR", "SVG")[1], suppress.warnings=FALSE)
{
lcpi <- last.plot.get.info();
if( plot.type[1] == "baseR" )
{
if( is.null(lcpi) || is.null(lcpi$baseR) )
{
if( !suppress.warnings ) .report.ewms("No CMA plot or no base R was generated!\n", "error", "get.plotted.partial.cmas", "AdhereR");
return (NULL);
} else
{
if( is.null(lcpi$baseR$partialCMAs) )
{
if( !suppress.warnings ) .report.ewms("No partial CMAs: are you sur this is the right type of CMA and that the partial CMAs were actually plotted?\n", "error", "get.plotted.partial.cmas", "AdhereR");
return (NULL);
} else
{
return (lcpi$baseR$partialCMAs);
}
}
} else if( plot.type[1] == "SVG" )
{
if( is.null(lcpi) || is.null(lcpi$SVG) )
{
if( !suppress.warnings ) .report.ewms("No CMA plot or no SVG was generated!\n", "error", "get.plotted.partial.cmas", "AdhereR");
return (NULL);
} else
{
if( is.null(lcpi$SVG$partialCMAs) )
{
if( !suppress.warnings ) .report.ewms("No partial CMAs: are you sur this is the right type of CMA and that the partial CMAs were actually plotted?\n", "error", "get.plotted.partial.cmas", "AdhereR");
return (NULL);
} else
{
return (lcpi$SVG$partialCMAs);
}
}
} else
{
if( !suppress.warnings ) .report.ewms("Unknown plot type!\n", "error", "get.plotted.partial.cmas", "AdhereR");
return (NULL);
}
}
## The plotting function ####
.plot.CMAs <- function(cma, # the CMA_per_episode or CMA_sliding_window (or derived) object
patients.to.plot=NULL, # list of patient IDs to plot or NULL for all
duration=NA, # duration and end period to plot in days (if missing, determined from the data)
align.all.patients=FALSE, align.first.event.at.zero=FALSE, # should all patients be aligned? and, if so, place the first event as the horizontal 0?
show.period=c("dates","days")[2], # draw vertical bars at regular interval as dates or days?
period.in.days=90, # the interval (in days) at which to draw vertical lines
show.legend=TRUE, legend.x="right", legend.y="bottom", legend.bkg.opacity=0.5, legend.cex=0.75, legend.cex.title=1.0, # legend params and position
cex=1.0, cex.axis=0.75, cex.lab=1.0, cex.title=1.5, # various graphical params
show.cma=TRUE, # show the CMA type
xlab=c("dates"="Date", "days"="Days"), # Vector of x labels to show for the two types of periods, or a single value for both, or NULL for nothing
ylab=c("withoutCMA"="patient", "withCMA"="patient (& CMA)"), # Vector of y labels to show without and with CMA estimates, or a single value for both, or NULL for nothing
title=c("aligned"="Event patterns (all patients aligned)", "notaligned"="Event patterns"), # Vector of titles to show for and without alignment, or a single value for both, or NULL for nothing
col.cats=rainbow, # single color or a function mapping the categories to colors
unspecified.category.label="drug", # the label of the unspecified category of medication
medication.groups.to.plot=NULL, # the names of the medication groups to plot (by default, all)
medication.groups.separator.show=TRUE, medication.groups.separator.lty="solid", medication.groups.separator.lwd=2, medication.groups.separator.color="blue", # group medication events by patient?
medication.groups.allother.label="*", # the label to use for the __ALL_OTHERS__ medication class (defaults to *)
lty.event="solid", lwd.event=2, pch.start.event=15, pch.end.event=16, # event style
show.event.intervals=TRUE, # show the actual prescription intervals
show.overlapping.event.intervals=c("first", "last", "min gap", "max gap", "average")[1], # how to plot overlapping event intervals (relevant for sliding windows and per episode)
plot.events.vertically.displaced=TRUE, # display the events on different lines (vertical displacement) or not (defaults to TRUE)?
print.dose=FALSE, cex.dose=0.75, print.dose.col="black", print.dose.outline.col="white", print.dose.centered=FALSE, # print daily dose
plot.dose=FALSE, lwd.event.max.dose=8, plot.dose.lwd.across.medication.classes=FALSE, # draw daily dose as line width
col.na="lightgray", # color for missing data
col.continuation="black", lty.continuation="dotted", lwd.continuation=1, # style of the continuation lines connecting consecutive events
print.CMA=TRUE, CMA.cex=0.50, # print CMA next to the participant's ID?
plot.CMA=TRUE, # plot the CMA next to the participant ID?
plot.CMA.as.histogram=TRUE, # plot CMA as a histogram or as a density plot?
plot.partial.CMAs.as=c("stacked", "overlapping", "timeseries")[1], # how to plot the "partial" (i.e., intervals/episodes) CMAs (NULL for none)?
plot.partial.CMAs.as.stacked.col.bars="gray90", plot.partial.CMAs.as.stacked.col.border="gray30", plot.partial.CMAs.as.stacked.col.text="black",
plot.partial.CMAs.as.timeseries.vspace=7, # how much vertical space to reserve for the timeseries plot (in character lines)
plot.partial.CMAs.as.timeseries.start.from.zero=TRUE, #show the vertical axis start at 0 or at the minimum actual value (if positive)?
plot.partial.CMAs.as.timeseries.col.dot="darkblue", plot.partial.CMAs.as.timeseries.col.interval="gray70", plot.partial.CMAs.as.timeseries.col.text="firebrick", # setting any of these to NA results in them not being plotted
plot.partial.CMAs.as.timeseries.interval.type=c("none", "segments", "arrows", "lines", "rectangles")[2], # how to show the covered intervals
plot.partial.CMAs.as.timeseries.lwd.interval=1, # line width for some types of intervals
plot.partial.CMAs.as.timeseries.alpha.interval=0.25, # the transparency of the intervals (when drawn as rectangles)
plot.partial.CMAs.as.timeseries.show.0perc=TRUE, plot.partial.CMAs.as.timeseries.show.100perc=FALSE, #show the 0% and 100% lines?
plot.partial.CMAs.as.overlapping.alternate=TRUE, # should successive intervals be plotted low/high?
plot.partial.CMAs.as.overlapping.col.interval="gray70", plot.partial.CMAs.as.overlapping.col.text="firebrick", # setting any of these to NA results in them not being plotted
CMA.plot.ratio=0.10, # the proportion of the total horizontal plot to be taken by the CMA plot
CMA.plot.col="lightgreen", CMA.plot.border="darkgreen", CMA.plot.bkg="aquamarine", CMA.plot.text=CMA.plot.border, # attributes of the CMA plot
highlight.followup.window=TRUE, followup.window.col="green",
highlight.observation.window=TRUE, observation.window.col="yellow", observation.window.density=35, observation.window.angle=-30, observation.window.opacity=0.3,
show.real.obs.window.start=TRUE, real.obs.window.density=35, real.obs.window.angle=30, # for CMA8, the real observation window starts at a different date
print.episode.or.sliding.window=FALSE, # should we print the episode or sliding window to which an event belongs?
alternating.bands.cols=c("white", "gray95"), # the colors of the alternating vertical bands across patients (NULL or NA=don't draw any; can be >= 1 color)
rotate.text=-60, # some text (e.g., axis labels) may be rotated by this much degrees
force.draw.text=FALSE, # if true, always draw text even if too big or too small
bw.plot=FALSE, # if TRUE, override all user-given colors and replace them with a scheme suitable for grayscale plotting
min.plot.size.in.characters.horiz=0, min.plot.size.in.characters.vert=0, # the minimum plot size (in characters: horizontally, for the whole duration, vertically, per event (and, if shown, per episode/sliding window))
max.patients.to.plot=100, # maximum number of patients to plot
suppress.warnings=FALSE, # suppress warnings?
export.formats=NULL, # the formats to export the figure to (by default, none); can be any subset of "svg" (just SVG file), "html" (SVG + HTML + CSS + JavaScript all embedded within the HTML document), "jpg", "png", "webp", "ps" and "pdf"
export.formats.fileprefix="AdhereR-plot", # the file name prefix for the exported formats
export.formats.height=NA, export.formats.width=NA, # desired dimensions (in pixels) for the exported figure (defaults to sane values)
export.formats.save.svg.placeholder=TRUE,
export.formats.svg.placeholder.type=c("jpg", "png", "webp")[2],
export.formats.svg.placeholder.embed=FALSE, # save a placeholder for the SVG image?
export.formats.html.template=NULL, export.formats.html.javascript=NULL, export.formats.html.css=NULL, # HTML, JavaScript and CSS templates for exporting HTML+SVG
export.formats.directory=NA, # if exporting, which directory to export to (if not give, creates files in the temporary directory)
generate.R.plot=TRUE, # generate standard (base R) plot for plotting within R?
do.not.draw.plot=FALSE, # if TRUE, don't draw the actual plot, but only the legend (if required)
...
)
{
# What sorts of plots to generate (use short names for short if statements):
.do.R <- generate.R.plot; .do.SVG <- (!is.null(export.formats) && any(c("svg", "html", "jpg", "png", "webp", "ps", "pdf") %in% export.formats));
if( !.do.R && !.do.SVG )
{
# Nothing to plot!
return (invisible(NULL));
}
# There is a confusion in the help concerning align.first.event.at.zero, so negate it:
align.first.event.at.zero <- !align.first.event.at.zero;
if( !is.null(medication.groups.to.plot) && length(medication.groups.to.plot) == 1 && is.na(medication.groups.to.plot) ) medication.groups.to.plot <- NULL; # NA has the same effect as NULL
#
# Initialize the SVG file content ####
#
# Things to remember about SVGs:
# - coordinates start top-left and go right and bottom
# - font size is relative to the viewBox
#
if( .do.SVG )
{
# The SVG header and string (body):
svg.header <- c('<?xml version="1.0" standalone="no"?>\n',
'<!DOCTYPE svg PUBLIC "-//W3C//DTD SVG 1.1//EN" "http://www.w3.org/Graphics/SVG/1.1/DTD/svg11.dtd">\n');
}
svg.str <- list(); #svg.str <- NULL; # some cases need (even an empty) svg.str...
#
# Set-up, checks and local functions ####
#
# Preconditions:
if( is.null(cma) || # must be: non-null
!(inherits(cma, "CMA_per_episode") || inherits(cma, "CMA_sliding_window") || inherits(cma, "CMA0")) || # a proper CMA object
is.null(cma$data) || nrow(cma$data) < 1 || !inherits(cma$data, "data.frame") || # that contains non-null data derived from data.frame
is.na(cma$ID.colname) || !(cma$ID.colname %in% names(cma$data)) || # has a valid patient ID column
is.na(cma$event.date.colname) || !(cma$event.date.colname %in% names(cma$data)) || # has a valid event date column
is.na(cma$event.duration.colname) || !(cma$event.duration.colname %in% names(cma$data)) # has a valid event duration column
)
{
if( !suppress.warnings ) .report.ewms("Can only plot a correctly specified CMA object (i.e., with valid data and column names)!\n", "error", ".plot.CMAs", "AdhereR");
plot.CMA.error(export.formats=export.formats,
export.formats.fileprefix=export.formats.fileprefix,
export.formats.directory=export.formats.directory,
generate.R.plot=generate.R.plot);
return (invisible(NULL));
}
# Overriding dangerous or aesthetic defaults:
if( force.draw.text && !suppress.warnings ) .report.ewms("Forcing drawing of text elements even if too big or ugly!\n", "warning", ".plot.CMAs", "AdhereR");
# SVG placeholder:
if( export.formats.save.svg.placeholder && (length(export.formats.svg.placeholder.type) != 1 || !export.formats.svg.placeholder.type %in% c("jpg", "png", "webp")) )
{
if( !suppress.warnings ) .report.ewms("The SVG place holder can only be a jpg, png or webp!\n", "error", ".plot.CMAs", "AdhereR");
plot.CMA.error(export.formats=export.formats,
export.formats.fileprefix=export.formats.fileprefix,
export.formats.directory=export.formats.directory,
generate.R.plot=generate.R.plot);
return (invisible(NULL));
}
# Local functions for the various types of summary CMA plots:
.plot.summary.CMA.as.histogram <- function(adh, svg.str)
{
adh.hist <- hist(adh, plot=FALSE);
adh.x <- adh.hist$breaks[-1]; adh.x.0 <- min(adh.x,0); adh.x.1 <- max(adh.x,1); adh.x <- (adh.x - adh.x.0) / (adh.x.1 - adh.x.0);
adh.y <- adh.hist$counts; adh.y <- adh.y / max(adh.y);
adh.x.max <- adh.x[which.max(adh.hist$counts)];
if( .do.R ) # Rplot
{
segments(.rescale.xcoord.for.CMA.plot(adh.x), y.mean - 2, .rescale.xcoord.for.CMA.plot(adh.x), y.mean - 2 + 4*adh.y, lty="solid", lwd=1, col=CMA.plot.border);
if( force.draw.text || char.height.CMA <= abs(.rescale.xcoord.for.CMA.plot(1.0) - .rescale.xcoord.for.CMA.plot(0.0)) )
{
# There's enough space for vertically writing all three of them:
text(x=.rescale.xcoord.for.CMA.plot(0.0), y.mean - 2 - char.height.CMA/2,
sprintf("%.1f%%",100*min(adh.x.0,na.rm=TRUE)), srt=90, pos=1, cex=CMA.cex, col=CMA.plot.text);
text(x=.rescale.xcoord.for.CMA.plot(1.0), y.mean - 2 - char.height.CMA/2,
sprintf("%.1f%%",100*max(adh.x.1,na.rm=TRUE)), srt=90, pos=1, cex=CMA.cex, col=CMA.plot.text);
text(x=.rescale.xcoord.for.CMA.plot(adh.x.max), y.mean + 2 + char.height.CMA/2,
sprintf("%d",max(adh.hist$counts,an.rm=TRUE)), srt=90, pos=3, cex=CMA.cex, col=CMA.plot.text);
}
}
if( .do.SVG ) # SVG
{
svg.str[[length(svg.str)+1]] <-
.SVG.comment("The CMA summary as histogram", newpara=TRUE)
svg.str[[length(svg.str)+1]] <- lapply(seq_along(adh.x), function(j)
{
# The CMA as histogram:
.SVG.lines(x=rep(.scale.x.to.SVG.plot(.rescale.xcoord.for.CMA.plot(adh.x[j])),2),
y=c(.scale.y.to.SVG.plot(y.mean - 2), .scale.y.to.SVG.plot(y.mean - 2 + 4*adh.y[j])),
connected=FALSE,
stroke=CMA.plot.border, stroke_width=1,
class="cma-summary-plot", suppress.warnings=suppress.warnings);
});
if( force.draw.text || 3*dims.chr.cma <= abs(.scale.width.to.SVG.plot(.rescale.xcoord.for.CMA.plot(1.0) - .rescale.xcoord.for.CMA.plot(0.0))) )
{
# There's enough space for vertically writing all three of them:
svg.str[[length(svg.str)+1]] <-
# The CMA as histogram:
.SVG.text(x=c(.scale.x.to.SVG.plot(.rescale.xcoord.for.CMA.plot(0.0)),
.scale.x.to.SVG.plot(.rescale.xcoord.for.CMA.plot(1.0)),
.scale.x.to.SVG.plot(.rescale.xcoord.for.CMA.plot(adh.x.max))),
y=c(.scale.y.to.SVG.plot(y.mean - 2 - 0.25),
.scale.y.to.SVG.plot(y.mean - 2 - 0.25),
.scale.y.to.SVG.plot(y.mean + 2 + 0.25)),
text=c(sprintf("%.1f%%",100*min(adh.x.0,na.rm=TRUE)),
sprintf("%.1f%%",100*max(adh.x.1,na.rm=TRUE)),
sprintf("%d",max(adh.hist$counts,an.rm=TRUE))),
col=CMA.plot.text, font_size=dims.chr.cma,
h.align=c("right","right","left"),
v.align="center",
rotate=c(-(90+rotate.text),-(90+rotate.text),-90),
class="cma-summary-text", suppress.warnings=suppress.warnings);
}
}
return (svg.str);
}
.plot.summary.CMA.as.density <- function(adh.x, adh.y, svg.str)
{
adh.x.0 <- min(adh.x,0); adh.x.1 <- max(adh.x,1); adh.x <- (adh.x - adh.x.0) / (adh.x.1 - adh.x.0);
adh.y <- (adh.y - min(adh.y)) / (max(adh.y) - min(adh.y));
if( .do.R ) # Rplot:
{
points(.rescale.xcoord.for.CMA.plot(adh.x), y.mean - 2 + 4*adh.y, type="l", col=CMA.plot.border);
if( force.draw.text || char.height.CMA <= abs(.rescale.xcoord.for.CMA.plot(1) - .rescale.xcoord.for.CMA.plot(0)) )
{
# There's enough space for vertical writing:
text(x=.rescale.xcoord.for.CMA.plot(0.0), y.mean - 2 - char.height.CMA/2, sprintf("%.1f%%",100*adh.x.0), srt=90, pos=1, cex=CMA.cex, col=CMA.plot.text);
text(x=.rescale.xcoord.for.CMA.plot(1.0), y.mean - 2 - char.height.CMA/2, sprintf("%.1f%%",100*adh.x.1), srt=90, pos=1, cex=CMA.cex, col=CMA.plot.text);
}
}
if( .do.SVG ) # SVG:
{
svg.str[[length(svg.str)+1]] <-
.SVG.comment("The CMA summary as density", newpara=TRUE);
svg.str[[length(svg.str)+1]] <-
# The individual lines:
.SVG.lines(x=.scale.x.to.SVG.plot(.rescale.xcoord.for.CMA.plot(adh.x)),
y=.scale.y.to.SVG.plot(y.mean - 2 + 4*adh.y),
connected=TRUE,
stroke=CMA.plot.border, stroke_width=1,
class="cma-summary-plot", suppress.warnings=suppress.warnings);
if( force.draw.text || 2*dims.chr.cma <= abs(.scale.width.to.SVG.plot(.rescale.xcoord.for.CMA.plot(1.0) - .rescale.xcoord.for.CMA.plot(0.0))) )
{
# There's enough space for vertical writing:
svg.str[[length(svg.str)+1]] <-
# The actual values as text:
.SVG.text(x=c(.scale.x.to.SVG.plot(.rescale.xcoord.for.CMA.plot(0.0)),
.scale.x.to.SVG.plot(.rescale.xcoord.for.CMA.plot(1.0))),
y=c(.scale.y.to.SVG.plot(y.mean - 2 - 0.25),
.scale.y.to.SVG.plot(y.mean - 2 - 0.25)),
text=c(sprintf("%.1f%%",100*adh.x.0),
sprintf("%.1f%%",100*adh.x.1)),
col=CMA.plot.text, font_size=dims.chr.cma,
h.align=c("right","right"), v.align="center", rotate=rotate.text,
class="cma-summary-text", suppress.warnings=suppress.warnings);
}
}
return (svg.str);
}
.plot.summary.CMA.as.lines <- function(adh, svg.str)
{
adh.x.0 <- min(adh,0); adh.x.1 <- max(adh,1); adh.x <- (adh - adh.x.0) / (adh.x.1 - adh.x.0);
if( .do.R ) # Rplot:
{
segments(.rescale.xcoord.for.CMA.plot(adh.x), y.mean - 2, .rescale.xcoord.for.CMA.plot(adh.x), y.mean - 2 + 4, lty="solid", lwd=2, col=CMA.plot.border);
if( char.height.CMA*length(adh) <= abs(.rescale.xcoord.for.CMA.plot(1) - .rescale.xcoord.for.CMA.plot(0)) )
{
# There's enough space for vertical writing all of them (alternated):
for( j in 1:length(adh) )
{
text(x=.rescale.xcoord.for.CMA.plot(adh.x[j]), y.mean + ifelse(j %% 2==0, 2 + char.height.CMA/2, -2 - char.height.CMA/2),
sprintf("%.1f%%",100*adh[j]), srt=90, pos=ifelse(j %% 2==0, 3, 1), cex=CMA.cex, col=CMA.plot.text);
}
} else if( force.draw.text || char.height.CMA <= abs(.rescale.xcoord.for.CMA.plot(1) - .rescale.xcoord.for.CMA.plot(0)) )
{
# There's enough space for vertical writing only the extremes:
text(x=.rescale.xcoord.for.CMA.plot(adh.x[1]), y.mean - 2 - char.height.CMA/2,
sprintf("%.1f%%",100*adh[1]), srt=90, pos=1, cex=CMA.cex, col=CMA.plot.text);
text(x=.rescale.xcoord.for.CMA.plot(adh.x[length(adh)]), y.mean - 2 - char.height.CMA/2,
sprintf("%.1f%%",100*adh[length(adh)]), srt=90, pos=1, cex=CMA.cex, col=CMA.plot.text);
}
}
if( .do.SVG ) # SVG:
{
svg.str[[length(svg.str)+1]] <-
.SVG.comment("The CMA summary as barplot", newpara=TRUE);
svg.str[[length(svg.str)+1]] <-
lapply(seq_along(adh.x), function(j)
{
# The individual lines:
.SVG.lines(x=rep(.scale.x.to.SVG.plot(.rescale.xcoord.for.CMA.plot(adh.x[j])),2),
y=c(.scale.y.to.SVG.plot(y.mean - 2), .scale.y.to.SVG.plot(y.mean - 2 + 4)),
connected=FALSE,
stroke=CMA.plot.border, stroke_width=2,
class="cma-summary-plot", suppress.warnings=suppress.warnings);
});
if( length(adh)*dims.chr.cma <= abs(.scale.width.to.SVG.plot(.rescale.xcoord.for.CMA.plot(1.0) - .rescale.xcoord.for.CMA.plot(0.0))) )
{
# There's enough space for vertical writing all of them (alternated):
svg.str[[length(svg.str)+1]] <-
# The actual values as text:
.SVG.text(x=.scale.x.to.SVG.plot(.rescale.xcoord.for.CMA.plot(adh.x)),
y=.scale.y.to.SVG.plot(y.mean + rep(c(-2 - 0.25, 2 + 0.25),times=length(adh))[1:length(adh)]),
text=sprintf("%.1f%%",100*adh),
col=CMA.plot.text, font_size=dims.chr.cma,
h.align=rep(c("right", "left"),times=length(adh))[1:length(adh)], v.align="center", rotate=rotate.text,
class="cma-summary-text", suppress.warnings=suppress.warnings);
} else if( force.draw.text || 2*dims.chr.cma <= abs(.scale.width.to.SVG.plot(.rescale.xcoord.for.CMA.plot(1.0) - .rescale.xcoord.for.CMA.plot(0.0))) )
{
# There's enough space for vertical writing only the extremes:
svg.str[[length(svg.str)+1]] <-
# The actual values as text:
.SVG.text(x=c(.scale.x.to.SVG.plot(.rescale.xcoord.for.CMA.plot(adh.x[1])),
.scale.x.to.SVG.plot(.rescale.xcoord.for.CMA.plot(adh.x[length(adh)]))),
y=c(.scale.y.to.SVG.plot(y.mean - 2 - 0.25),
.scale.y.to.SVG.plot(y.mean - 2 - 0.25)),
text=c(sprintf("%.1f%%",100*adh[1]),
sprintf("%.1f%%",100*adh[length(adh)])),
col=CMA.plot.text, font_size=dims.chr.cma,
h.align=c("right","right"), v.align="center",
rotate=c(-90,-90),
class="cma-summary-text", suppress.warnings=suppress.warnings);
}
}
return (svg.str);
}
# Legend plotting auxiliary functions ####
if( show.legend )
{
if( .do.R )
{
.legend.R <- function(x=0, y=0, width=1, height=1, do.plot=TRUE)
{
# Legend rectangle:
if( do.plot )
{
rect(x, y, x + width, y + height, border=gray(0.6), lwd=2, col=rgb(0.99,0.99,0.99,legend.bkg.opacity));
# Save the info:
.last.cma.plot.info$baseR$legend <<- list("box"=data.frame("x.start"=x, "y.start"=y, "x.end"=x+width, "y.end"=y+height));
.last.cma.plot.info$baseR$legend$components <<- NULL;
}
cur.y <- y + height; # current y
max.width <- width; # maximum width
# Legend title:
if( do.plot )
{
text(x + width/2, cur.y, "Legend", pos=1, col=gray(0.3), cex=legend.cex.title);
# Save the info:
.last.cma.plot.info$baseR$legend$title <<- data.frame("string"="Legend", "x"=x+width/2, "y"=cur.y, "cex"=legend.cex.title);
}
cur.y <- cur.y - strheight("Legend", cex=legend.cex.title) - 3*legend.char.height; max.width <- max(max.width, strwidth("Legend", cex=legend.cex.title));
# Event:
if( do.plot )
{
segments(x + 1.0*legend.char.width, cur.y, x + 4.0*legend.char.width, cur.y, lty=lty.event, lwd=lwd.event, col="black");
points(x + 1.0*legend.char.width, cur.y, pch=pch.start.event, cex=legend.cex, col="black");
points(x + 4.0*legend.char.width, cur.y, pch=pch.end.event, cex=legend.cex, col="black");
}
if( !plot.dose )
{
if( do.plot )
{
text(x + 5.0*legend.char.width, cur.y, "duration", col="black", cex=legend.cex, pos=4);
# Save the info:
.last.cma.plot.info$baseR$legend$components <<- rbind(.last.cma.plot.info$baseR$legend$components,
data.frame("string"="duration",
"x.start"=x + 1.0*legend.char.width, "y.start"=cur.y,
"x.end"=x + 4.0*legend.char.width, "y.end"=cur.y,
"x.string"=x + 5.0*legend.char.width, "y.string"=cur.y,
"cex"=legend.cex));
}
cur.y <- cur.y - 1.5*legend.char.height; max.width <- max(max.width, 5.0*legend.char.width + strwidth("duration", cex=legend.cex));
} else
{
if( do.plot )
{
text(x + 5.0*legend.char.width, cur.y, "duration (min. dose)", col="black", cex=legend.cex, pos=4);
}
cur.y <- cur.y - 1.5*legend.char.height; max.width <- max(max.width, 5.0*legend.char.width + strwidth("duration (min. dose)", cex=legend.cex));
if( do.plot )
{
segments(x + 1.0*legend.char.width, cur.y, x + 4.0*legend.char.width, cur.y, lty=lty.event, lwd=lwd.event.max.dose, col="black");
points(x + 1.0*legend.char.width, cur.y, pch=pch.start.event, cex=legend.cex, col="black");
points(x + 4.0*legend.char.width, cur.y, pch=pch.end.event, cex=legend.cex, col="black");
text(x + 5.0*legend.char.width, cur.y, "duration (max. dose)", col="black", cex=legend.cex, pos=4);
# Save the info:
.last.cma.plot.info$baseR$legend$components <<- rbind(.last.cma.plot.info$baseR$legend$components,
data.frame("string"=c("duration (min. dose)", "duration (max. dose)"),
"x.start"=rep(x + 1.0*legend.char.width,2), "y.start"=c(cur.y + 1.5*legend.char.height, cur.y),
"x.end"=rep(x + 4.0*legend.char.width,2), "y.end"=c(cur.y + 1.5*legend.char.height, cur.y),
"x.string"=rep(x + 5.0*legend.char.width,2), "y.string"=c(cur.y + 1.5*legend.char.height, cur.y),
"cex"=legend.cex));
}
cur.y <- cur.y - 1.5*legend.char.height; max.width <- max(max.width, 5.0*legend.char.width + strwidth("duration (max. dose)", cex=legend.cex));
}
# No event:
if( do.plot )
{
segments(x + 1.0*legend.char.width, cur.y, x + 4.0*legend.char.width, cur.y, lty=lty.continuation, lwd=lwd.continuation, col=col.continuation);
text(x + 5.0*legend.char.width, cur.y, "no event/connector", col="black", cex=legend.cex, pos=4);
# Save the info:
.last.cma.plot.info$baseR$legend$components <<- rbind(.last.cma.plot.info$baseR$legend$components,
data.frame("string"="no event/connector",
"x.start"=x + 1.0*legend.char.width, "y.start"=cur.y,
"x.end"=x + 4.0*legend.char.width, "y.end"=cur.y,
"x.string"=x + 5.0*legend.char.width, "y.string"=cur.y,
"cex"=legend.cex));
}
cur.y <- cur.y - 1.5*legend.char.height; max.width <- max(max.width, 5.0*legend.char.width + strwidth("no event/connector", cex=legend.cex));
# Event intervals:
if( show.event.intervals )
{
if( do.plot )
{
rect(x + 1.0*legend.char.width, cur.y, x + 4.0*legend.char.width, cur.y - 1.0*legend.char.height, border="black", col=adjustcolor("black",alpha.f=0.5));
text(x + 5.0*legend.char.width, cur.y - 0.5*legend.char.height, "days covered", col="black", cex=legend.cex, pos=4);
# Save the info:
.last.cma.plot.info$baseR$legend$components <<- rbind(.last.cma.plot.info$baseR$legend$components,
data.frame("string"="days covered",
"x.start"=x + 1.0*legend.char.width, "y.start"=cur.y,
"x.end"=x + 4.0*legend.char.width, "y.end"=cur.y - 1.0*legend.char.height,
"x.string"=x + 5.0*legend.char.width, "y.string"=cur.y - 0.5*legend.char.height,
"cex"=legend.cex));
}
cur.y <- cur.y - 1.5*legend.char.height; max.width <- max(max.width, 5.0*legend.char.width + strwidth("days covered", cex=legend.cex));
if( do.plot )
{
rect(x + 1.0*legend.char.width, cur.y, x + 4.0*legend.char.width, cur.y - 1.0*legend.char.height, border="black", col=NA); #, col="black", density=25);
text(x + 5.0*legend.char.width, cur.y - 0.5*legend.char.height, "gap days", col="black", cex=legend.cex, pos=4);
# Save the info:
.last.cma.plot.info$baseR$legend$components <<- rbind(.last.cma.plot.info$baseR$legend$components,
data.frame("string"="gap days",
"x.start"=x + 1.0*legend.char.width, "y.start"=cur.y,
"x.end"=x + 4.0*legend.char.width, "y.end"=cur.y - 1.0*legend.char.height,
"x.string"=x + 5.0*legend.char.width, "y.string"=cur.y - 0.5*legend.char.height,
"cex"=legend.cex));
}
cur.y <- cur.y - 2.0*legend.char.height; max.width <- max(max.width, 5.0*legend.char.width + strwidth("gap days", cex=legend.cex));
}
# medication classes:
for( i in 1:length(cols) )
{
med.class.name <- names(cols)[i]; med.class.name <- ifelse(is.na(med.class.name),"<missing>",med.class.name);
if( do.plot )
{
rect(x + 1.0*legend.char.width, cur.y, x + 4.0*legend.char.width, cur.y - 1.0*legend.char.height, border="black", col=adjustcolor(cols[i],alpha.f=0.5));
med.class.name <- names(cols)[i]; med.class.name <- ifelse(is.na(med.class.name),"<missing>",med.class.name);
if( print.dose || plot.dose )
{
dose.for.cat <- (dose.range$category == med.class.name);
if( sum(dose.for.cat,na.rm=TRUE) == 1 )
{
med.class.name <- paste0(med.class.name," (",dose.range$min[dose.for.cat]," - ",dose.range$max[dose.for.cat],")");
}
}
text(x + 5.0*legend.char.width, cur.y - 0.5*legend.char.height, med.class.name, col="black", cex=legend.cex, pos=4);
# Save the info:
.last.cma.plot.info$baseR$legend$components <<- rbind(.last.cma.plot.info$baseR$legend$components,
data.frame("string"=med.class.name,
"x.start"=x + 1.0*legend.char.width, "y.start"=cur.y,
"x.end"=x + 4.0*legend.char.width, "y.end"=cur.y - 1.0*legend.char.height,
"x.string"=x + 5.0*legend.char.width, "y.string"=cur.y - 0.5*legend.char.height,
"cex"=legend.cex));
}
cur.y <- cur.y - 1.5*legend.char.height; max.width <- max(max.width, 5.0*legend.char.width + strwidth(names(cols)[i], cex=legend.cex));
}
cur.y <- cur.y - 0.5*legend.char.height;
# Follow-up window:
if( highlight.followup.window )
{
if( do.plot )
{
rect(x + 1.0*legend.char.width, cur.y, x + 4.0*legend.char.width, cur.y - 1.0*legend.char.height, border=followup.window.col, lty="dotted", lwd=2, col=rgb(1,1,1,0.0));
text(x + 5.0*legend.char.width, cur.y - 0.5*legend.char.height, "follow-up wnd.", col="black", cex=legend.cex, pos=4);
# Save the info:
.last.cma.plot.info$baseR$legend$components <<- rbind(.last.cma.plot.info$baseR$legend$components,
data.frame("string"="follow-up wnd.",
"x.start"=x + 1.0*legend.char.width, "y.start"=cur.y,
"x.end"=x + 4.0*legend.char.width, "y.end"=cur.y - 1.0*legend.char.height,
"x.string"=x + 5.0*legend.char.width, "y.string"=cur.y - 0.5*legend.char.height,
"cex"=legend.cex));
}
cur.y <- cur.y - 2.0*legend.char.height; max.width <- max(max.width, 5.0*legend.char.width + strwidth("follow-up wnd.", cex=legend.cex));
}
# Observation window:
if( highlight.observation.window )
{
if( !is.null(cma.realOW) )
{
# CMA8 also has a "real" OW:
if( do.plot )
{
rect(x + 1.0*legend.char.width, cur.y, x + 4.0*legend.char.width, cur.y - 1.0*legend.char.height,
border=rgb(1,1,1,0.0), col=adjustcolor(observation.window.col,alpha.f=observation.window.opacity)); #, density=observation.window.density, angle=observation.window.angle);
text(x + 5.0*legend.char.width, cur.y - 0.5*legend.char.height, "theor. obs. wnd.", col="black", cex=legend.cex, pos=4);
# Save the info:
.last.cma.plot.info$baseR$legend$components <<- rbind(.last.cma.plot.info$baseR$legend$components,
data.frame("string"="theor. obs. wnd.",
"x.start"=x + 1.0*legend.char.width, "y.start"=cur.y,
"x.end"=x + 4.0*legend.char.width, "y.end"=cur.y - 1.0*legend.char.height,
"x.string"=x + 5.0*legend.char.width, "y.string"=cur.y - 0.5*legend.char.height,
"cex"=legend.cex));
}
cur.y <- cur.y - 1.5*legend.char.height; max.width <- max(max.width, 5.0*legend.char.width + strwidth("theor. obs. wnd.", cex=legend.cex));
if( do.plot )
{
rect(x + 1.0*legend.char.width, cur.y, x + 4.0*legend.char.width, cur.y - 1.0*legend.char.height,
border=rgb(1,1,1,0.0), col=adjustcolor(observation.window.col,alpha.f=observation.window.opacity)); #, density=real.obs.window.density, angle=real.obs.window.angle);
text(x + 5.0*legend.char.width, cur.y - 0.5*legend.char.height, "real obs. wnd.", col="black", cex=legend.cex, pos=4);
# Save the info:
.last.cma.plot.info$baseR$legend$components <<- rbind(.last.cma.plot.info$baseR$legend$components,
data.frame("string"="real obs. wnd.",
"x.start"=x + 1.0*legend.char.width, "y.start"=cur.y,
"x.end"=x + 4.0*legend.char.width, "y.end"=cur.y - 1.0*legend.char.height,
"x.string"=x + 5.0*legend.char.width, "y.string"=cur.y - 0.5*legend.char.height,
"cex"=legend.cex));
}
cur.y <- cur.y - 2.0*legend.char.height; max.width <- max(max.width, 5.0*legend.char.width + strwidth("real obs.wnd.", cex=legend.cex));
} else
{
if( do.plot )
{
rect(x + 1.0*legend.char.width, cur.y, x + 4.0*legend.char.width, cur.y - 1.0*legend.char.height,
border=rgb(1,1,1,0.0), col=adjustcolor(observation.window.col,alpha.f=observation.window.opacity)) #, density=observation.window.density, angle=observation.window.angle);
text(x + 5.0*legend.char.width, cur.y - 0.5*legend.char.height, "observation wnd.", col="black", cex=legend.cex, pos=4);
# Save the info:
.last.cma.plot.info$baseR$legend$components <<- rbind(.last.cma.plot.info$baseR$legend$components,
data.frame("string"="observation wnd.",
"x.start"=x + 1.0*legend.char.width, "y.start"=cur.y,
"x.end"=x + 4.0*legend.char.width, "y.end"=cur.y - 1.0*legend.char.height,
"x.string"=x + 5.0*legend.char.width, "y.string"=cur.y - 0.5*legend.char.height,
"cex"=legend.cex));
}
cur.y <- cur.y - 2.0*legend.char.height; max.width <- max(max.width, 5.0*legend.char.width + strwidth("observation wnd.", cex=legend.cex));
}
}
# Required size:
return (c("width" =max.width + 5.0*legend.char.width,
"height"=(y + height - cur.y) + 1.0*legend.char.height));
}
}
if( .do.SVG )
{
.legend.SVG <- function(x=0, y=0, do.plot=TRUE)
{
if( do.plot )
{
# The legend is an object that we can move around, scale, etc:
l1 <- c(.SVG.comment("The legend", newpara=TRUE, newline=TRUE),
'<g id="legend">\n');
}
# The legend origins:
x.origin <- ifelse(!do.plot || is.numeric(x), x, 0.0); y.origin <- ifelse(!do.plot || is.numeric(y), y, 0.0);
# Save the info:
.last.cma.plot.info$SVG$legend <<- list();
.last.cma.plot.info$SVG$legend$components <<- NULL;
# The legend dimensions and other aesthetics:
lw <- lh <- 0; # width and height
lmx <- dims.chr.legend; lmy <- 2 # margins
lnl <- 1.25; lnp <- 0.25; # the vertical size of a newline and newpara (in dims.chr.legend)
# The actual legend content:
# The legend title:
if( do.plot )
{
l2 <- c(.SVG.text(x=x.origin + lmx, y=y.origin + lmy+lh+dims.chr.legend.title*2/3, text="Legend",
font_size=dims.chr.legend.title, font="Arial", h.align="left", v.align="center", col="gray30",
class="legend-title", suppress.warnings=suppress.warnings));
# Save the info:
.last.cma.plot.info$SVG$legend$title <<- data.frame("string"="Legend", "x"=x.origin + lmx, "y"=y.origin + lmy+lh+dims.chr.legend.title*2/3, "font.size"=dims.chr.legend.title);
}
lh <- lh + dims.chr.legend.title + lnl*dims.chr.legend; lw <- max(lw, .SVG.string.dims("Legend", font_size=dims.chr.legend.title)["width"]);
lh <- lh + lnp*dims.chr.legend.title; # new para
# The event:
if( do.plot )
{
l2 <- c(l2,
.SVG.lines(x=x.origin + c(lmx, lmx + 3*dims.chr.legend), y=y.origin + c(lmy+lh, lmy+lh),
connected=FALSE, stroke="black", stroke_width=lwd.event, lty=lty.event,
class="legend-events", suppress.warnings=suppress.warnings),
.SVG.points(x=x.origin + c(lmx, lmx + 3*dims.chr.legend), y=y.origin + c(lmy+lh, lmy+lh),
pch=c(pch.start.event, pch.end.event), col="black", cex=legend.cex,
class="legend-events", suppress.warnings=suppress.warnings));
}
if( !plot.dose )
{
if( do.plot )
{
l2 <- c(l2,
.SVG.text(x=x.origin + lmx + 4*dims.chr.legend, y=y.origin + lmy+lh, text="duration",
col="black", font_size=dims.chr.legend, h.align="left", v.align="center",
class="legend-events", suppress.warnings=suppress.warnings));
# Save the info:
.last.cma.plot.info$SVG$legend$components <<- rbind(.last.cma.plot.info$SVG$legend$components,
data.frame("string"="duration",
"x.start"=x.origin + lmx, "y.start"=y.origin + lmy+lh,
"x.end"=x.origin + lmx + 3*dims.chr.legend, "y.end"=y.origin + lmy+lh,
"x.string"=lmx + 4*dims.chr.legend, "y.string"=lmy+lh,
"font.size"=dims.chr.legend));
}
lh <- lh + lnl*dims.chr.legend; lw <- max(lw, .SVG.string.dims("duration", font_size=dims.chr.legend)["width"] + 4*dims.chr.legend);
} else
{
# Min dose:
if( do.plot )
{
l2 <- c(l2,
.SVG.text(x=x.origin + lmx + 4*dims.chr.legend, y=y.origin + lmy+lh, text="duration (min. dose)",
col="black", font_size=dims.chr.legend, h.align="left", v.align="center",
class="legend-events", suppress.warnings=suppress.warnings));
# Save the info:
.last.cma.plot.info$SVG$legend$components <<- rbind(.last.cma.plot.info$SVG$legend$components,
data.frame("string"="duration (min. dose)",
"x.start"=x.origin + lmx, "y.start"=y.origin + lmy+lh,
"x.end"=x.origin + lmx + 3*dims.chr.legend, "y.end"=y.origin + lmy+lh,
"x.string"=lmx + 4*dims.chr.legend, "y.string"=lmy+lh,
"font.size"=dims.chr.legend));
}
lh <- lh + lnl*dims.chr.legend; lw <- max(lw, .SVG.string.dims("duration (min. dose)", font_size=dims.chr.legend)["width"] + 4*dims.chr.legend);
# Max dose:
if( do.plot )
{
l2 <- c(l2,
.SVG.lines(x=x.origin + c(lmx, lmx + 3*dims.chr.legend), y=y.origin + c(lmy+lh, lmy+lh),
connected=FALSE, stroke="black", stroke_width=lwd.event.max.dose, lty=lty.event,
class="legend-events", suppress.warnings=suppress.warnings),
.SVG.points(x=x.origin + c(lmx, lmx + 3*dims.chr.legend), y=y.origin + c(lmy+lh, lmy+lh),
pch=c(pch.start.event, pch.end.event),col="black", cex=legend.cex,
class="legend-events", suppress.warnings=suppress.warnings),
.SVG.text(x=x.origin + lmx + 4*dims.chr.legend, y=y.origin + lmy+lh, text="duration (max. dose)",
col="black", font_size=dims.chr.legend, h.align="left", v.align="center",
class="legend-events", suppress.warnings=suppress.warnings));
# Save the info:
.last.cma.plot.info$SVG$legend$components <<- rbind(.last.cma.plot.info$SVG$legend$components,
data.frame("string"="duration (max. dose)",
"x.start"=x.origin + lmx, "y.start"=y.origin + lmy+lh,
"x.end"=x.origin + lmx + 3*dims.chr.legend, "y.end"=y.origin + lmy+lh,
"x.string"=lmx + 4*dims.chr.legend, "y.string"=lmy+lh,
"font.size"=dims.chr.legend));
}
lh <- lh + lnl*dims.chr.legend; lw <- max(lw, .SVG.string.dims("duration (max. dose)", font_size=dims.chr.legend)["width"] + 4*dims.chr.legend);
}
# No event:
if( do.plot )
{
l2 <- c(l2,
.SVG.lines(x=x.origin + c(lmx, lmx + 3*dims.chr.legend), y=y.origin + c(lmy+lh, lmy+lh),
connected=FALSE, stroke=col.continuation, stroke_width=lwd.continuation, lty=lty.continuation,
class="legend-no-event", suppress.warnings=suppress.warnings),
.SVG.text(x=x.origin + lmx + 4*dims.chr.legend, y=y.origin + lmy+lh, text="no event/connector",
col="black", font_size=dims.chr.legend, h.align="left", v.align="center",
class="legend-no-event", suppress.warnings=suppress.warnings));
# Save the info:
.last.cma.plot.info$SVG$legend$components <<- rbind(.last.cma.plot.info$SVG$legend$components,
data.frame("string"="no event/connector",
"x.start"=x.origin + lmx, "y.start"=y.origin + lmy+lh,
"x.end"=x.origin + lmx + 3*dims.chr.legend, "y.end"=y.origin + lmy+lh,
"x.string"=lmx + 4*dims.chr.legend, "y.string"=lmy+lh,
"font.size"=dims.chr.legend));
}
lh <- lh + lnl*dims.chr.legend; lw <- max(lw, .SVG.string.dims("no event/connector", font_size=dims.chr.legend)["width"] + 4*dims.chr.legend);
lh <- lh + lnp*dims.chr.legend.title; # new para
# Event intervals:
if( show.event.intervals )
{
if( do.plot )
{
l2 <- c(l2,
.SVG.rect(x=x.origin + lmx, y=y.origin + lmy+lh-dims.chr.legend/2, width=3*dims.chr.legend, height=1*dims.chr.legend,
stroke="black", fill="black", fill_opacity=0.5,
class="legend-interval"),
.SVG.text(x=x.origin + lmx + 4*dims.chr.legend, y=y.origin + lmy+lh, text="days covered",
col="black", font_size=dims.chr.legend, h.align="left", v.align="center",
class="legend-interval", suppress.warnings=suppress.warnings));
# Save the info:
.last.cma.plot.info$SVG$legend$components <<- rbind(.last.cma.plot.info$SVG$legend$components,
data.frame("string"="days covered",
"x.start"=x.origin + lmx, "y.start"=y.origin + lmy+lh,
"x.end"=x.origin + lmx + 3*dims.chr.legend, "y.end"=y.origin + lmy+lh,
"x.string"=lmx + 4*dims.chr.legend, "y.string"=lmy+lh,
"font.size"=dims.chr.legend));
}
lh <- lh + lnl*dims.chr.legend; lw <- max(lw, .SVG.string.dims("days covered", font_size=dims.chr.legend)["width"] + 4*dims.chr.legend);
if( do.plot )
{
l2 <- c(l2,
.SVG.rect(x=x.origin + lmx, y=y.origin + lmy+lh-dims.chr.legend/2, width=3*dims.chr.legend, height=1*dims.chr.legend,
stroke="black", fill="none",
class="legend-interval"),
.SVG.text(x=x.origin + lmx + 4*dims.chr.legend, y=y.origin + lmy+lh, text="gap days",
col="black", font_size=dims.chr.legend, h.align="left", v.align="center",
class="legend-interval", suppress.warnings=suppress.warnings));
# Save the info:
.last.cma.plot.info$SVG$legend$components <<- rbind(.last.cma.plot.info$SVG$legend$components,
data.frame("string"="gap days",
"x.start"=x.origin + lmx, "y.start"=y.origin + lmy+lh,
"x.end"=x.origin + lmx + 3*dims.chr.legend, "y.end"=y.origin + lmy+lh,
"x.string"=lmx + 4*dims.chr.legend, "y.string"=lmy+lh,
"font.size"=dims.chr.legend));
}
lh <- lh + lnl*dims.chr.legend; lw <- max(lw, .SVG.string.dims("gap days", font_size=dims.chr.legend)["width"] + 4*dims.chr.legend);
lh <- lh + lnp*dims.chr.legend.title; # new para
}
# Medication classes:
for( i in 1:length(cols) )
{
med.class.name <- names(cols)[i]; med.class.name <- ifelse(is.na(med.class.name),"<missing>",med.class.name);
if( (is.na(cma$medication.class.colname) || !(cma$medication.class.colname %in% names(cma$data))) && length(cols) == 1 )
{
med.class.name.svg <- NA;
} else
{
med.class.name.svg <- .map.category.to.class(med.class.name);
}
if( do.plot )
{
l2 <- c(l2,
.SVG.rect(x=x.origin + lmx, y=y.origin + lmy+lh-dims.chr.legend/2, width=3*dims.chr.legend, height=1*dims.chr.legend,
stroke="black", fill=cols[i], fill_opacity=0.5,
class=paste0("legend-medication-class-rect", if(med.class.name != "<missing>" && !is.na(med.class.name.svg)) paste0("-",med.class.name.svg) )));
}
#med.class.name <- names(cols)[i]; med.class.name <- ifelse(is.na(med.class.name),"<missing>",med.class.name);
if( print.dose || plot.dose )
{
dose.for.cat <- (dose.range$category == med.class.name);
if( sum(dose.for.cat,na.rm=TRUE) == 1 )
{
med.class.name <- paste0(med.class.name," (",dose.range$min[dose.for.cat]," - ",dose.range$max[dose.for.cat],")");
}
}
if( do.plot )
{
l2 <- c(l2,
.SVG.text(x=x.origin + lmx + 4*dims.chr.legend, y=y.origin + lmy+lh, text=med.class.name,
col="black", font_size=dims.chr.legend, h.align="left", v.align="center",
class=paste0("legend-medication-class-label", if(med.class.name != "<missing>" && !is.na(med.class.name.svg)) paste0("-",med.class.name.svg) ),
suppress.warnings=suppress.warnings));
# Save the info:
.last.cma.plot.info$SVG$legend$components <<- rbind(.last.cma.plot.info$SVG$legend$components,
data.frame("string"=med.class.name,
"x.start"=x.origin + lmx, "y.start"=y.origin + lmy+lh-dims.chr.legend/2,
"x.end"=x.origin + lmx + 3*dims.chr.legend, "y.end"=y.origin + lmy+lh-dims.chr.legend/2+1*dims.chr.legend,
"x.string"=lmx + 4*dims.chr.legend, "y.string"=lmy+lh,
"font.size"=dims.chr.legend));
}
lh <- lh + lnl*dims.chr.legend; lw <- max(lw, .SVG.string.dims(med.class.name, font_size=dims.chr.legend)["width"] + 4*dims.chr.legend);
}
lh <- lh + lnp*dims.chr.legend.title; # new para
# Follow-up window:
if( highlight.followup.window )
{
if( do.plot )
{
l2 <- c(l2,
.SVG.rect(x=x.origin + lmx, y=y.origin + lmy+lh-dims.chr.legend/2, width=3*dims.chr.legend, height=1*dims.chr.legend,
stroke=followup.window.col, fill="none", stroke_width=2, lty="dashed",
class="legend-fuw-rect"),
.SVG.text(x=x.origin + lmx + 4*dims.chr.legend, y=y.origin + lmy+lh, text="follow-up wnd.",
col="black", font_size=dims.chr.legend, h.align="left", v.align="center",
class="legend-fuw-label", suppress.warnings=suppress.warnings));
# Save the info:
.last.cma.plot.info$SVG$legend$components <<- rbind(.last.cma.plot.info$SVG$legend$components,
data.frame("string"="follow-up wnd.",
"x.start"=x.origin + lmx, "y.start"=y.origin + lmy+lh-dims.chr.legend/2,
"x.end"=x.origin + lmx + 3*dims.chr.legend, "y.end"=y.origin + lmy+lh-dims.chr.legend/2+1*dims.chr.legend,
"x.string"=lmx + 4*dims.chr.legend, "y.string"=lmy+lh,
"font.size"=dims.chr.legend));
}
lh <- lh + lnl*dims.chr.legend; lw <- max(lw, .SVG.string.dims("follow-up wnd", font_size=dims.chr.legend)["width"] + 4*dims.chr.legend);
}
# Observation window:
if( highlight.observation.window )
{
if( !is.null(cma.realOW) )
{
# CMA8 also has a "real" OW:
if( do.plot )
{
l2 <- c(l2,
.SVG.rect(x=x.origin + lmx, y=y.origin + lmy+lh-dims.chr.legend/2, width=3*dims.chr.legend, height=1*dims.chr.legend,
stroke="none", fill=observation.window.col, fill_opacity=observation.window.opacity,
class="legend-ow-rect"),
.SVG.text(x=x.origin + lmx + 4*dims.chr.legend, y=y.origin + lmy+lh, text="theor. obs. wnd.",
col="black", font_size=dims.chr.legend, h.align="left", v.align="center",
class="legend-ow-label", suppress.warnings=suppress.warnings));
# Save the info:
.last.cma.plot.info$SVG$legend$components <<- rbind(.last.cma.plot.info$SVG$legend$components,
data.frame("string"="theor. obs. wnd.",
"x.start"=x.origin + lmx, "y.start"=y.origin + lmy+lh-dims.chr.legend/2,
"x.end"=x.origin + lmx + 3*dims.chr.legend, "y.end"=y.origin + lmy+lh-dims.chr.legend/2+1*dims.chr.legend,
"x.string"=lmx + 4*dims.chr.legend, "y.string"=lmy+lh,
"font.size"=dims.chr.legend));
}
lh <- lh + lnl*dims.chr.legend; lw <- max(lw, .SVG.string.dims("theor. obs. wnd", font_size=dims.chr.legend)["width"] + 4*dims.chr.legend);
if( do.plot )
{
l2 <- c(l2,
.SVG.rect(x=x.origin + lmx, y=y.origin + lmy+lh-dims.chr.legend/2, width=3*dims.chr.legend, height=1*dims.chr.legend,
stroke="none", fill=observation.window.col, fill_opacity=observation.window.opacity,
class="legend-ow-real"),
.SVG.text(x=x.origin + lmx + 4*dims.chr.legend, y=y.origin + lmy+lh, text="real obs. wnd.",
col="black", font_size=dims.chr.legend, h.align="left", v.align="center",
class="legend-ow-real", suppress.warnings=suppress.warnings));
# Save the info:
.last.cma.plot.info$SVG$legend$components <<- rbind(.last.cma.plot.info$SVG$legend$components,
data.frame("string"="real obs. wnd.",
"x.start"=x.origin + lmx, "y.start"=y.origin + lmy+lh-dims.chr.legend/2,
"x.end"=x.origin + lmx + 3*dims.chr.legend, "y.end"=y.origin + lmy+lh-dims.chr.legend/2+1*dims.chr.legend,
"x.string"=lmx + 4*dims.chr.legend, "y.string"=lmy+lh,
"font.size"=dims.chr.legend));
}
lh <- lh + lnl*dims.chr.legend; lw <- max(lw, .SVG.string.dims("real obs. wnd.", font_size=dims.chr.legend)["width"] + 4*dims.chr.legend);
} else
{
if( do.plot )
{
l2 <- c(l2,
.SVG.rect(x=x.origin + lmx, y=y.origin + lmy+lh-dims.chr.legend/2, width=3*dims.chr.legend, height=1*dims.chr.legend,
stroke="none", fill=observation.window.col, fill_opacity=observation.window.opacity,
class="legend-ow-rect"),
.SVG.text(x=x.origin + lmx + 4*dims.chr.legend, y=y.origin + lmy+lh, text="observation wnd.",
col="black", font_size=dims.chr.legend, h.align="left", v.align="center",
class="legend-ow-label", suppress.warnings=suppress.warnings));
# Save the info:
.last.cma.plot.info$SVG$legend$components <<- rbind(.last.cma.plot.info$SVG$legend$components,
data.frame("string"="observation wnd.",
"x.start"=x.origin + lmx, "y.start"=y.origin + lmy+lh-dims.chr.legend/2,
"x.end"=x.origin + lmx + 3*dims.chr.legend, "y.end"=y.origin + lmy+lh-dims.chr.legend/2+1*dims.chr.legend,
"x.string"=lmx + 4*dims.chr.legend, "y.string"=lmy+lh,
"font.size"=dims.chr.legend));
}
lh <- lh + lnl*dims.chr.legend; lw <- max(lw, .SVG.string.dims("duration", font_size=dims.chr.legend)["width"] + 4*dims.chr.legend);
}
}
# The legend background:
lbox <- .SVG.rect(x=x.origin, y=y.origin, width=lw+2*lmx, height=lh+2*lmy, stroke="gray60", stroke_width=2, fill="gray99", fill_opacity=legend.bkg.opacity, class="legend-background");
if( !do.plot )
{
# The legend position:
if( is.null(x) || length(x) > 1 || is.na(x) || !(x %in% c("left", "center", "right") || is.numeric(x)) ) x <- "right";
if( is.na(x) || x == "right" )
{
x <- (dims.plot.x + dims.plot.width - lw - 3*lmx);
} else if( x == "center" )
{
x <- (dims.plot.x + lmx + (dims.plot.width - lmx - lw)/2);
} else if( x == "left" )
{
x <- (dims.plot.x + lmx);
} else
{
x <- .scale.x.to.SVG.plot(x);
}
if( is.null(y) || length(y) > 1 || is.na(y) || !(y %in% c("top", "center", "bottom") || is.numeric(y)) ) y <- "bottom";
if( is.na(y) || y == "bottom" )
{
y <- (dims.plot.y + dims.plot.height - lh - 3*lmy);
} else if( y == "center" )
{
y <- (dims.plot.y + (dims.plot.height - lh - 2*lmy)/2);
} else if( y == "top" )
{
y <- (dims.plot.y + lmy);
} else
{
y <- .scale.y.to.SVG.plot(y);
}
}
if( do.plot )
{
# Close the legend:
l2 <- c(l2,
'</g>\n');
}
# Save the info:
.last.cma.plot.info$SVG$legend$box <<- data.frame("x.start"=x, "y.start"=y, "x.end"=x+lw+2*lmx, "y.end"=y+lh+2*lmy);
if( do.plot )
{
# Insert the legend background where it should be:
return (c(l1, lbox, l2));
} else
{
return (NULL);
}
}
}
}
# Is the cma a time series or per episodes?
is.cma.TS.or.SW <- (inherits(cma, "CMA_per_episode") || inherits(cma, "CMA_sliding_window"));
# Does the cma contains estimated CMAs?
has.estimated.CMA <- !is.null(getCMA(cma));
# Convert data.table to data.frame (basically, to guard against inconsistencies between data.table and data.frame in how they handle d[,i]):
if( inherits(cma$data, "data.table") ) cma$data <- as.data.frame(cma$data);
# Check compatibility between subtypes of plots:
if( align.all.patients && show.period != "days" ){ show.period <- "days"; if( !suppress.warnings ) .report.ewms("When aligning all patients, cannot show actual dates: showing days instead!\n", "warning", ".plot.CMAs", "AdhereR"); }
#
# Cache useful column names ####
#
cma.mg <- !is.null(cma$medication.groups); # are there medication groups?
col.patid <- cma$ID.colname; # patient ID
if( !cma.mg )
{
col.plotid <- col.patid; # when no medication groups, the plotting ID is the same the patient ID
} else
{
col.mg <- cma$medication.groups.colname;
col.plotid <- paste0("__",col.patid, ":", col.mg,"__"); # when there are medication groups, the plotting ID is patient ID concatenated with the medication group
}
cma.data <- cma$data; # the original data
# Given a patient ID and medication group name, form the display label:
if( cma.mg )
{
.mg.label <- function(patients, medication.groups)
{
paste0(patients," [",ifelse(medication.groups=="__ALL_OTHERS__", medication.groups.allother.label, medication.groups),"]");
}
}
#
# If CMA8, cache the real observation windows if it is to be plotted ####
#
if( inherits(cma,"CMA8") && !is.null(cma$real.obs.window) && show.real.obs.window.start )
{
cma.realOW <- cma$real.obs.window;
} else
{
cma.realOW <- NULL;
}
#
# Medication groups: expand the data and keep only those patient x group that contain events ####
#
if( cma.mg )
{
# Expand the data to contain all the patient x groups:
cma$data <- do.call(rbind, lapply(1:ncol(cma$medication.groups$obs), function(i)
{
if( !is.null(medication.groups.to.plot) && length(medication.groups.to.plot) > 0 &&
!(colnames(cma$medication.groups$obs)[i] %in% medication.groups.to.plot) )
{
# Not all medication groups should be plotted and this is one of them!
return (NULL);
}
tmp <- cma$data[cma$medication.groups$obs[,i],];
if( is.null(tmp) || nrow(tmp) == 0 )
{
return (NULL);
} else
{
tmp <- cbind(tmp, colnames(cma$medication.groups$obs)[i]); names(tmp)[ncol(tmp)] <- col.mg;
return (tmp);
}
}));
# Keep only those that actually have events and that should be plotted:
patmgids <- unique(cma$data[,c(col.patid, col.mg)]);
if( is.null(patmgids) || nrow(patmgids) == 0 )
{
# Nothing to plot!
if( !suppress.warnings ) .report.ewms("No patients to plot!\n", "error", ".plot.CMAs", "AdhereR");
plot.CMA.error(export.formats=export.formats,
export.formats.fileprefix=export.formats.fileprefix,
export.formats.directory=export.formats.directory,
generate.R.plot=generate.R.plot);
return (invisible(NULL));
}
# Add the new column containing the patient ID and the medication group for plotting:
cma$data <- cbind(cma$data, .mg.label(cma$data[,col.patid], cma$data[,col.mg])); names(cma$data)[ncol(cma$data)] <- col.plotid;
patmgids <- cbind(patmgids, .mg.label(patmgids[,col.patid], patmgids[,col.mg])); names(patmgids)[ncol(patmgids)] <- col.plotid;
# The data should be already fine: focus on the CMA estimates:
if( !is.null(cma$CMA) )
{
if( cma$flatten.medication.groups )
{
cma$CMA <- cma$CMA[ vapply(1:nrow(cma$CMA), function(i) any(cma$CMA[i,col.patid] == patmgids[,col.patid] & cma$CMA[i,col.mg] == patmgids[,col.mg]), logical(1)), ];
} else
{
tmp <- lapply(1:length(cma$CMA), function(i)
{
tmp <- cma$CMA[[i]];
if( is.null(tmp) ) return (NULL);
tmp <- tmp[ tmp[,col.patid] %in% patmgids[patmgids[,col.mg] == names(cma$CMA)[i], col.patid], ];
if( is.null(tmp) || nrow(tmp) == 0 ) return (NULL) else return (tmp);
});
names(tmp) <- names(cma$CMA); cma$CMA <- tmp;
}
}
if( !is.null(cma.realOW) )
{
if( cma$flatten.medication.groups )
{
# Nothing to do, the real OW is already a data.frame!
} else
{
# Flatten the OW:
tmp <- do.call(rbind, cma.realOW);
if( is.null(tmp) || nrow(tmp) == 0 )
{
cma.realOW <- NULL;
} else
{
tmp <- cbind(tmp, unlist(lapply(1:length(cma.realOW), function(i) if(!is.null(cma.realOW[[i]])){rep(names(cma.realOW)[i], nrow(cma.realOW[[i]]))}else{NULL})));
names(tmp)[ncol(tmp)] <- cma$medication.groups.colname; rownames(tmp) <- NULL;
cma.realOW <- tmp;
}
}
# Add the new column containing the patient ID and the medication group for plotting:
cma.realOW <- cbind(cma.realOW, .mg.label(cma.realOW[,col.patid], cma.realOW[,col.mg])); names(cma.realOW)[ncol(cma.realOW)] <- col.plotid;
}
}
#
# Select patients ####
#
# The patients:
patients.to.plot <- patients.to.plot[ !duplicated(patients.to.plot) ]; # remove duplicates keeping the order
patids <- unique(as.character(cma$data[,col.patid])); patids <- patids[!is.na(patids)];
if( !is.null(patients.to.plot) ) patids <- intersect(patids, as.character(patients.to.plot));
if( length(patids) == 0 )
{
if( !suppress.warnings ) .report.ewms("No patients to plot!\n", "error", ".plot.CMAs", "AdhereR");
plot.CMA.error(export.formats=export.formats,
export.formats.fileprefix=export.formats.fileprefix,
export.formats.directory=export.formats.directory,
generate.R.plot=generate.R.plot);
return (invisible(NULL));
} else if( length(patids) > max.patients.to.plot )
{
if( !suppress.warnings ) .report.ewms(paste0("Too many patients to plot (",length(patids),
")! If this is the desired outcome, please change the 'max.patients.to.plot' parameter value (now set at ",
max.patients.to.plot,") to at least ',length(patids),'!\n"), "error", ".plot.CMAs", "AdhereR");
plot.CMA.error(export.formats=export.formats,
export.formats.fileprefix=export.formats.fileprefix,
export.formats.directory=export.formats.directory,
generate.R.plot=generate.R.plot);
return (invisible(NULL));
}
# Select only the patients to display:
cma <- subsetCMA(cma, patids);
if( cma.mg )
{
patmgids <- patmgids[ patmgids[,col.patid] %in% patids, ];
}
##
## Checks and conversions of various column types
##
# Patient IDs and medical class better be characters:
cma$data[, col.patid] <- as.character(cma$data[, col.patid]);
if(!is.na(cma$medication.class.colname) && cma$medication.class.colname %in% names(cma$data))
{
cma$data[, cma$medication.class.colname] <- as.character(cma$data[, cma$medication.class.colname]);
}
#
# Cache, consolidate and homogenise the needed info (events, CMAs, FUW an OW) ####
#
# Cache the CMA estimates (if any):
if( !cma.mg )
{
# No medication groups:
cmas <- getCMA(cma);
} else
{
# There are medication groups:
if( cma$flatten.medication.groups )
{
cmas <- getCMA(cma); cma.mg.colname <- col.mg;
} else
{
cmas <- getCMA(cma, flatten.medication.groups=TRUE); cma.mg.colname <- names(cmas)[ncol(cmas)];
}
# Add the new column containing the patient ID and the medication group for plotting:
if( !is.null(cmas) )
{
cmas <- cbind(cmas, .mg.label(cmas[,col.patid], cmas[,col.mg])); names(cmas)[ncol(cmas)] <- col.plotid;
}
}
# Keep only those patients with non-missing CMA estimates:
if( !is.null(cmas) )
{
if( inherits(cmas, "data.table") ) cmas <- as.data.frame(cmas); # same conversion to data.frame as above
non_missing_cmas <- cmas[ !is.na(cmas[,"CMA"]), ]; non_missing_cma_patids <- unique(as.character(non_missing_cmas[,col.patid]));
if( is.null(non_missing_cma_patids) || length(non_missing_cma_patids) == 0 )
{
if( !suppress.warnings ) .report.ewms("No patients with CMA estimates: nothing to plot!\n", "error", ".plot.CMAs", "AdhereR");
plot.CMA.error(export.formats=export.formats,
export.formats.fileprefix=export.formats.fileprefix,
export.formats.directory=export.formats.directory,
generate.R.plot=generate.R.plot);
return (invisible(NULL));
}
}
# The patients that have no events to plot:
patids.no.events.to.plot <- NULL;
# Depending on the cma's exact type, the relevant columns might be different or even absent: homogenize them for later use
if( inherits(cma, "CMA_per_episode") )
{
names(cmas)[2:7] <- c("WND.ID", "start", "gap.days", "duration", "end", "CMA"); # avoid possible conflict with patients being called "ID"
# Remove the participants without CMA estimates:
patids.no.events.to.plot <- setdiff(unique(cma$data[,col.patid]), unique(cmas[,col.patid]));
if( length(patids.no.events.to.plot) > 0 )
{
cma$data <- cma$data[ !(cma$data[,col.patid] %in% patids.no.events.to.plot), ];
cma$event.info <- cma$event.info[ !(cma$event.info[,col.patid] %in% patids.no.events.to.plot), ];
#cma$data[ nrow(cma$data) + 1:length(patids.no.events.to.plot), col.patid ] <- patids.no.events.to.plot; # everything ese is NA except for the patient id
if( !suppress.warnings ) .report.ewms(paste0("Patient",
ifelse(length(patids.no.events.to.plot) > 1, "s ", " "),
paste0("'",patids.no.events.to.plot, "'", collapse=", "),
ifelse(length(patids.no.events.to.plot) > 1, " have ", " has "), " no events to plot!\n"),
"warning", ".plot.CMAs", "AdhereR");
}
} else if( inherits(cma, "CMA_sliding_window") )
{
cmas <- cbind(cmas[,1:3], "gap.days"=NA, "duration"=cma$sliding.window.duration, cmas[,4:ncol(cmas)]);
names(cmas)[2:7] <- c("WND.ID", "start", "gap.days", "duration", "end", "CMA"); # avoid possible conflict with patients being called "ID"
# Remove the participants without CMA estimates:
patids.no.events.to.plot <- setdiff(unique(cma$data[,col.patid]), unique(cmas[,col.patid]));
if( length(patids.no.events.to.plot) > 0 )
{
cma$data <- cma$data[ !(cma$data[,col.patid] %in% patids.no.events.to.plot), ];
cma$event.info <- cma$event.info[ !(cma$event.info[,col.patid] %in% patids.no.events.to.plot), ];
#cma$data[ nrow(cma$data) + 1:length(patids.no.events.to.plot), col.patid ] <- patids.no.events.to.plot; # everything ese is NA except for the patient id
if( !suppress.warnings ) .report.ewms(paste0("Patient",
ifelse(length(patids.no.events.to.plot) > 1, "s ", " "),
paste0("'",patids.no.events.to.plot, "'", collapse=", "),
ifelse(length(patids.no.events.to.plot) > 1, " have ", " has "), " no events to plot!\n"),
"warning", ".plot.CMAs", "AdhereR");
}
} else if( inherits(cma, "CMA0") && is.null(cma$event.info) )
{
# Try to compute the event.info:
if( !cma.mg )
{
# No medication groups:
event.info <- compute.event.int.gaps(data=cma$data,
ID.colname=col.patid,
event.date.colname=cma$event.date.colname,
event.duration.colname=cma$event.duration.colname,
event.daily.dose.colname=cma$event.daily.dose.colname,
medication.class.colname=cma$medication.class.colname,
event.interval.colname="event.interval",
gap.days.colname="gap.days",
carryover.within.obs.window=FALSE,
carryover.into.obs.window=FALSE,
carry.only.for.same.medication=FALSE,
consider.dosage.change=FALSE,
followup.window.start=cma$followup.window.start,
followup.window.start.unit=cma$followup.window.start.unit,
followup.window.duration=cma$followup.window.duration,
followup.window.duration.unit=cma$followup.window.duration.unit,
observation.window.start=cma$observation.window.start,
observation.window.start.unit=cma$observation.window.start.unit,
observation.window.duration=cma$observation.window.duration,
observation.window.duration.unit=cma$observation.window.duration.unit,
date.format=cma$date.format,
keep.window.start.end.dates=TRUE,
remove.events.outside.followup.window=FALSE,
keep.event.interval.for.all.events=TRUE,
parallel.backend="none", # make sure this runs sequentially!
parallel.threads=1,
suppress.warnings=FALSE,
return.data.table=FALSE);
if( !is.null(event.info) )
{
# Keep only those events that intersect with the observation window (and keep only the part that is within the intersection):
# Compute end prescription date as well:
event.info$.DATE.as.Date.end <- .add.time.interval.to.date(event.info$.DATE.as.Date, event.info[,cma$event.duration.colname], "days");
# Remove all treatments that end before FUW starts and those that start after FUW ends:
patids.all <- unique(event.info[,col.patid]);
event.info <- event.info[ !(event.info$.DATE.as.Date.end < event.info$.FU.START.DATE | event.info$.DATE.as.Date > event.info$.FU.END.DATE), ];
if( is.null(event.info) || nrow(event.info) == 0 )
{
if( !suppress.warnings ) .report.ewms("No events in the follow-up window: nothing to plot!\n", "error", ".plot.CMAs", "AdhereR");
plot.CMA.error(export.formats=export.formats,
export.formats.fileprefix=export.formats.fileprefix,
export.formats.directory=export.formats.directory,
generate.R.plot=generate.R.plot);
return (invisible(NULL));
}
patids.no.events.to.plot <- setdiff(patids.all, unique(event.info[,col.patid]));
# Find all prescriptions that start before the follow-up window and truncate them:
s <- (event.info$.DATE.as.Date < event.info$.FU.START.DATE);
if( length(s) > 0 )
{
event.info$.DATE.as.Date[s] <- event.info$.FU.START.DATE[s];
}
# Find all prescriptions that end after the follow-up window and truncate them:
s <- (event.info$.DATE.as.Date.end > event.info$.FU.END.DATE);
if( length(s) > 0 )
{
event.info[s,cma$event.duration.colname] <- .difftime.Dates.as.days(event.info$.FU.END.DATE[s], event.info$.DATE.as.Date[s]);
}
# Store the event.info data:
cma$event.info <- event.info;
# For the patients without stuff to plot, replace their events by a fake single event:
if( length(patids.no.events.to.plot) > 0 )
{
cma$data <- cma$data[ !(cma$data[,col.patid] %in% patids.no.events.to.plot), ];
cma$event.info <- cma$event.info[ !(cma$event.info[,col.patid] %in% patids.no.events.to.plot), ];
#cma$data[ nrow(cma$data) + 1:length(patids.no.events.to.plot), col.patid ] <- patids.no.events.to.plot; # everything ese is NA except for the patient id
if( !suppress.warnings ) .report.ewms(paste0("Patient",
ifelse(length(patids.no.events.to.plot) > 1, "s ", " "),
paste0("'",patids.no.events.to.plot, "'", collapse=", "),
ifelse(length(patids.no.events.to.plot) > 1, " have ", " has "), " no events to plot!\n"),
"warning", ".plot.CMAs", "AdhereR");
}
} else
{
if( !suppress.warnings ) .report.ewms("Error(s) concerning the follow-up and observation windows!\n", "error", ".plot.CMAs", "AdhereR");
plot.CMA.error(export.formats=export.formats,
export.formats.fileprefix=export.formats.fileprefix,
export.formats.directory=export.formats.directory,
generate.R.plot=generate.R.plot);
return (invisible(NULL));
}
} else
{
# There are medication groups:
# Do what the simple CMAs do: compute the event.info!
# The workhorse auxiliary function: For a given (subset) of data, compute the event intervals and gaps:
.workhorse.function <- function(data=NULL,
ID.colname=NULL,
event.date.colname=NULL,
event.duration.colname=NULL,
event.daily.dose.colname=NULL,
medication.class.colname=NULL,
event.interval.colname=NULL,
gap.days.colname=NULL,
carryover.within.obs.window=NULL,
carryover.into.obs.window=NULL,
carry.only.for.same.medication=NULL,
consider.dosage.change=NULL,
followup.window.start=NULL,
followup.window.start.unit=NULL,
followup.window.duration=NULL,
followup.window.duration.unit=NULL,
observation.window.start=NULL,
observation.window.start.unit=NULL,
observation.window.duration=NULL,
observation.window.duration.unit=NULL,
date.format=NULL,
suppress.warnings=NULL,
suppress.special.argument.checks=NULL
)
{
# Call the compute.event.int.gaps() function and use the results:
event.info <- compute.event.int.gaps(data=as.data.frame(data),
ID.colname=ID.colname,
event.date.colname=event.date.colname,
event.duration.colname=event.duration.colname,
event.daily.dose.colname=event.daily.dose.colname,
medication.class.colname=medication.class.colname,
event.interval.colname=event.interval.colname,
gap.days.colname=gap.days.colname,
carryover.within.obs.window=carryover.within.obs.window,
carryover.into.obs.window=carryover.into.obs.window,
carry.only.for.same.medication=carry.only.for.same.medication,
consider.dosage.change=consider.dosage.change,
followup.window.start=followup.window.start,
followup.window.start.unit=followup.window.start.unit,
followup.window.duration=followup.window.duration,
followup.window.duration.unit=followup.window.duration.unit,
observation.window.start=observation.window.start,
observation.window.start.unit=observation.window.start.unit,
observation.window.duration=observation.window.duration,
observation.window.duration.unit=observation.window.duration.unit,
date.format=date.format,
keep.window.start.end.dates=TRUE,
parallel.backend="none", # make sure this runs sequentially!
parallel.threads=1,
suppress.warnings=suppress.warnings,
suppress.special.argument.checks=TRUE,
return.data.table=TRUE);
if( is.null(event.info) ) return (list("CMA"=NA, "event.info"=NULL));
return (list("CMA"=NULL, "event.info"=event.info));
}
tmp <- .cma.skeleton(data=cma.data,
ret.val=cma,
cma.class.name=c("CMA0"),
ID.colname=col.patid,
event.date.colname=cma$event.date.colname,
event.duration.colname=cma$event.duration.colname,
event.daily.dose.colname=cma$event.daily.dose.colname,
medication.class.colname=cma$medication.class.colname,
event.interval.colname="event.interval",
gap.days.colname="gap.days",
carryover.within.obs.window=FALSE,
carryover.into.obs.window=FALSE,
carry.only.for.same.medication=FALSE,
consider.dosage.change=FALSE,
followup.window.start=cma$followup.window.start,
followup.window.start.unit=cma$followup.window.start.unit,
followup.window.duration=cma$followup.window.duration,
followup.window.duration.unit=cma$followup.window.duration.unit,
observation.window.start=cma$observation.window.start,
observation.window.start.unit=cma$observation.window.start.unit,
observation.window.duration=cma$observation.window.duration,
observation.window.duration.unit=cma$observation.window.duration.unit,
date.format=cma$date.format,
flatten.medication.groups=cma$flatten.medication.groups,
followup.window.start.per.medication.group=cma$followup.window.start.per.medication.group,
suppress.warnings=suppress.warnings,
suppress.special.argument.checks=TRUE,
force.NA.CMA.for.failed.patients=TRUE, # force the failed patients to have NA CMA estimates
parallel.backend="none", # make sure this runs sequentially!
parallel.threads=1,
.workhorse.function=.workhorse.function);
cma$event.info <- tmp$event.info;
}
} else
{
# Remove the participants without CMA estimates:
patids.no.events.to.plot <- setdiff(unique(cmas[, col.patid ]), unique(cmas[ !is.na(cmas$CMA), col.patid ]));
if( length(patids.no.events.to.plot) > 0 )
{
cma$data <- cma$data[ !(cma$data[,col.patid] %in% patids.no.events.to.plot), ];
cma$event.info <- cma$event.info[ !(cma$event.info[,col.patid] %in% patids.no.events.to.plot), ];
#cma$data[ nrow(cma$data) + 1:length(patids.no.events.to.plot), col.patid ] <- patids.no.events.to.plot; # everything else is NA except for the patient id
cmas <- cmas[ !(cmas[,col.patid] %in% patids.no.events.to.plot), ]
if( !suppress.warnings ) .report.ewms(paste0("Patient",
ifelse(length(patids.no.events.to.plot) > 1, "s ", " "),
paste0("'",patids.no.events.to.plot, "'", collapse=", "),
ifelse(length(patids.no.events.to.plot) > 1, " have ", " has "), " no events to plot!\n"),
"warning", ".plot.CMAs", "AdhereR");
}
}
# Cache the event.info:
if( !cma.mg )
{
# No medication groups:
evinfo <- getEventInfo(cma);
} else
{
# There are medication groups:
if( cma$flatten.medication.groups )
{
evinfo <- getEventInfo(cma); evinfo.mg.colname <- col.mg;
} else
{
evinfo <- getEventInfo(cma, flatten.medication.groups=TRUE); evinfo.mg.colname <- names(evinfo)[ncol(evinfo)];
}
}
# Add the follow-up and observation window info as well, to have everything in one place:
if( !is.null(cmas) )
{
cmas <- cbind(cmas, do.call(rbind, lapply(1:nrow(cmas), function(i)
{
if( !cma.mg )
{
s <- which(evinfo[,col.patid] == cmas[i,col.patid]);
} else
{
s <- which(evinfo[,col.patid] == cmas[i,col.patid] & evinfo[,evinfo.mg.colname] == cmas[i,cma.mg.colname]);
}
if( length(s) == 0 ) return(data.frame(".FU.START.DATE"=NA, ".FU.END.DATE"=NA, ".OBS.START.DATE"=NA, ".OBS.END.DATE"=NA)); #return (NULL);
evinfo[s[1],c(".FU.START.DATE", ".FU.END.DATE", ".OBS.START.DATE", ".OBS.END.DATE")];
})));
} else
{
# Create a fake one, containing but the follow-up and observation window info:
if( !cma.mg )
{
# No medication grops:
cmas <- data.frame("..patid.."=unique(cma$data[,col.patid]), "CMA"=NA); names(cmas)[1] <- col.patid;
if( !is.null(evinfo) )
{
cmas <- merge(cmas,
unique(evinfo[,c(col.patid, ".FU.START.DATE", ".FU.END.DATE", ".OBS.START.DATE", ".OBS.END.DATE")]),
by=c(col.patid), all.x=TRUE);
} else
{
cmas <- cbind(cmas, ".FU.START.DATE"=NA, ".FU.END.DATE"=NA, ".OBS.START.DATE"=NA, ".OBS.END.DATE"=NA);
}
} else
{
# There are medication groups:
cmas <- cbind(unique(cma$data[,c(col.patid, col.mg)]), "CMA"=NA);
if( !is.null(evinfo) )
{
cmas <- merge(cmas,
unique(evinfo[,c(col.patid, col.mg, ".FU.START.DATE", ".FU.END.DATE", ".OBS.START.DATE", ".OBS.END.DATE")]),
by=c(col.patid, col.mg), all.x=TRUE);
} else
{
cmas <- cbind(cmas, ".FU.START.DATE"=NA, ".FU.END.DATE"=NA, ".OBS.START.DATE"=NA, ".OBS.END.DATE"=NA);
}
# Add the new column containing the patient ID and the medication group for plotting:
cmas <- cbind(cmas, .mg.label(cmas[,col.patid], cmas[,col.mg])); names(cmas)[ncol(cmas)] <- col.plotid;
}
}
# Make sure the dates are cached as `Date` objects:
if( !inherits(cma$data[,cma$event.date.colname], "Date") )
{
if( is.na(cma$date.format) || is.null(cma$date.format) || length(cma$date.format) != 1 || !is.character(cma$date.format) )
{
if( !suppress.warnings ) .report.ewms("The date format must be a single string: cannot continue plotting!\n", "error", ".plot.CMAs", "AdhereR");
plot.CMA.error(export.formats=export.formats,
export.formats.fileprefix=export.formats.fileprefix,
export.formats.directory=export.formats.directory,
generate.R.plot=generate.R.plot);
return (invisible(NULL));
}
# Convert them to Date:
cma$data$.DATE.as.Date <- as.Date(cma$data[,cma$event.date.colname], format=cma$date.format);
if( anyNA(cma$data$.DATE.as.Date) )
{
if( !suppress.warnings ) .report.ewms(paste0("Not all entries in the event date \"",cma$event.date.colname,"\" column are valid dates or conform to the date format \"",cma$date.format,"\"; first issue occurs on row ",min(which(is.na(cma$data$.DATE.as.Date))),": cannot continue plotting!\n"), "error", ".plot.CMAs", "AdhereR");
plot.CMA.error(export.formats=export.formats,
export.formats.fileprefix=export.formats.fileprefix,
export.formats.directory=export.formats.directory,
generate.R.plot=generate.R.plot);
return (invisible(NULL));
}
} else
{
# Just make a copy:
cma$data$.DATE.as.Date <- cma$data[,cma$event.date.colname];
}
# Make sure the patients are ordered by ID, medication group (if the case), and date:
if( !is.null(patients.to.plot) && any(patients.to.plot %in% patids) )
{
# Respect the order given in patients.to.plot by converting everything to factor with a given levels order:
patids.ordered <- factor(patids, levels=patients.to.plot[patients.to.plot %in% patids]);
cma$data[,col.patid] <- factor(cma$data[,col.patid], levels=patients.to.plot[patients.to.plot %in% cma$data[,col.patid]]);
if( cma.mg ) patmgids[,col.patid] <- factor(patmgids[,col.patid], levels=patients.to.plot[patients.to.plot %in% patmgids[,col.patid]]);
cmas[,col.patid] <- factor(cmas[,col.patid], levels=patients.to.plot[patients.to.plot %in% cmas[,col.patid]]);
}
patids <- patids[ order(patids) ];
if( !cma.mg )
{
cma$data <- cma$data[ order(cma$data[,col.patid], cma$data$.DATE.as.Date), ];
} else
{
cma$data <- cma$data[ order(cma$data[,col.patid], cma$data[,col.mg], cma$data$.DATE.as.Date), ];
patmgids <- patmgids[ order(patmgids[,col.patid], patmgids[,col.mg]), ];
}
if( all(c("WND.ID","start") %in% names(cmas)) )
{
cmas <- cmas[ order(cmas[,col.patid], cmas$WND.ID, cmas$start), ];
} else
{
cmas <- cmas[ order(cmas[,col.patid]), ];
}
#
# Colors for plotting ####
#
# Grayscale plotting:
if( bw.plot )
{
if( is.function(col.cats) ) col.cats <- .bw.colors else col.cats <- gray(0.1);
followup.window.col <- "black";
observation.window.col <- gray(0.3);
CMA.plot.col <- gray(0.8);
CMA.plot.border <- gray(0.2);
CMA.plot.bkg <- gray(0.5);
CMA.plot.text <- CMA.plot.border;
col.na <- "lightgray";
col.continuation <- "black";
print.dose.outline.col <- "white";
plot.partial.CMAs.as.stacked.col.bars <- "gray90";
plot.partial.CMAs.as.stacked.col.border <- "gray30";
plot.partial.CMAs.as.stacked.col.text <- "black";
plot.partial.CMAs.as.timeseries.col.dot <- "black";
plot.partial.CMAs.as.timeseries.col.interval <- "gray70";
plot.partial.CMAs.as.timeseries.col.text <- "black";
plot.partial.CMAs.as.overlapping.col.interval <- "gray70";
plot.partial.CMAs.as.overlapping.col.text <- "black";
}
# The colors for the categories:
if( is.na(cma$medication.class.colname) || !(cma$medication.class.colname %in% names(cma$data)) )
{
categories <- unspecified.category.label;
} else
{
categories <- sort(unique(as.character(cma$data[,cma$medication.class.colname])), na.last=FALSE); # all categories making sure NA is first
}
if( is.na(categories[1]) )
{
if( is.function(col.cats) ) cols <- c(col.na, col.cats(length(categories)-1)) else cols <- c(col.na, rep(col.cats,length(categories)-1));
} else
{
if( is.function(col.cats) ) cols <- col.cats(length(categories)) else cols <- rep(col.cats,length(categories));
}
names(cols) <- categories;
# .map.category.to.color <- function(category, cols.array=cols) ifelse( is.na(category), cols.array[1], ifelse( category %in% names(cols.array), cols.array[category], "black") );
.map.category.to.color <- function(category, cols.array=cols)
{
if( is.na(category) )
{
return (cols.array[1]);
} else
{
if( category %in% names(cols.array) )
{
return (cols.array[category]);
} else
{
return ("black");
}
}
}
if( .do.SVG )
{
# Map category names to standardized category ids to be stored as class attributes; this mapping will be exported as a JavaScript dictionary in the HTML container(if any):
categories.to.classes <- paste0("med-class-",1:length(categories)); names(categories.to.classes) <- categories;
# .map.category.to.class <- function(category, cat2class=categories.to.classes) ifelse( is.na(category), cat2class[1],
# ifelse( category %in% names(cat2class), cat2class[category],
# cat2class[1]) );
.map.category.to.class <- function(category, cat2class=categories.to.classes)
{
if( is.na(category) )
{
return (cat2class[1]);
} else
{
if( category %in% names(cat2class) )
{
return (cat2class[category]);
} else
{
return (cat2class[1]);
}
}
}
}
#
# Doses ####
#
# Daily dose:
if( is.na(cma$event.daily.dose.colname) || !(cma$event.daily.dose.colname %in% names(cma$data)) )
{
print.dose <- plot.dose <- FALSE; # can't show daily dose if column is not defined
}
if( plot.dose || print.dose ) # consistency checks:
{
if( lwd.event.max.dose < lwd.event ) lwd.event.max.dose <- lwd.event;
}
if( plot.dose || print.dose )
{
if( length(categories) == 1 && categories == unspecified.category.label )
{
# Really, no category:
dose.range <- data.frame("category"=categories, "min"=min(cma$data[,cma$event.daily.dose.colname], na.rm=TRUE), "max"=max(cma$data[,cma$event.daily.dose.colname], na.rm=TRUE));
} else
{
# Range per category:
tmp <- aggregate(cma$data[,cma$event.daily.dose.colname], by=list("category"=cma$data[,cma$medication.class.colname]), FUN=function(x) range(x,na.rm=TRUE));
dose.range <- data.frame("category"=tmp$category, "min"=tmp$x[,1], "max"=tmp$x[,2]);
if( plot.dose.lwd.across.medication.classes )
{
dose.range.global <- data.frame("category"="ALL", "min"=min(cma$data[,cma$event.daily.dose.colname], na.rm=TRUE), "max"=max(cma$data[,cma$event.daily.dose.colname], na.rm=TRUE));
}
}
# Function for the linear interpolation of dose between lwd.min and lwd.max:
adjust.dose.lwd <- function(dose, lwd.min=lwd.event, lwd.max=lwd.event.max.dose, dose.min=dose.range$min[1], dose.max=dose.range$max[1])
{
delta <- ifelse(dose.max == dose.min, 1.0, (dose.max - dose.min)); # avoid dividing by zero when there's only one dose
return (lwd.min + (lwd.max - lwd.min)*(dose - dose.min) / delta);
}
}
#
# Episode or sliding window to which an event belongs ####
#
if( !(inherits(cma, "CMA_per_episode") && "mapping.episodes.to.events" %in% names(cma) && !is.null(cma$mapping.episodes.to.events)) && # for per episodes
!(inherits(cma, "CMA_sliding_window") && "mapping.windows.to.events" %in% names(cma) && !is.null(cma$mapping.windows.to.events)) ) # for sliding windows
{
print.episode.or.sliding.window <- FALSE; # can't show this info
}
#
# Event dates and durations ####
#
# Find the earliest date:
earliest.date <- min(cma$data$.DATE.as.Date, if( "start" %in% names(cmas) ) cmas$start, cmas$.OBS.START.DATE, cmas$.FU.START.DATE, na.rm=TRUE);
# If aligning all participants to the same date, simply relocate all dates relative to the earliest date:
if( align.all.patients )
{
# ASSUMPTIONS: the data is sorted by patient ID and (ascending) by event date
for( i in 1:nrow(cma$data) )
{
# For each event in the dataset:
if( i == 1 || cma$data[i,col.patid] != cma$data[i-1,col.patid] )
{
# It's a new patient (or the first one):
# We will align to the patient's first event:
align.to <- cma$data$.DATE.as.Date[i];
# Adjust the dates in the cmas as well:
for( j in which(cmas[,col.patid] == cma$data[i,col.patid]) )
{
if( "start" %in% names(cmas) ) cmas$start[j] <- earliest.date + (cmas$start[j] - align.to);
if( "end" %in% names(cmas) ) cmas$end[j] <- earliest.date + (cmas$end[j] - align.to);
cmas$.FU.START.DATE[j] <- earliest.date + (cmas$.FU.START.DATE[j] - align.to);
cmas$.FU.END.DATE[j] <- earliest.date + (cmas$.FU.END.DATE[j] - align.to);
cmas$.OBS.START.DATE[j] <- earliest.date + (cmas$.OBS.START.DATE[j] - align.to);
cmas$.OBS.END.DATE[j] <- earliest.date + (cmas$.OBS.END.DATE[j] - align.to);
}
}
# Move the event so that it is properly aligned:
cma$data$.DATE.as.Date[i] <- (earliest.date + (cma$data$.DATE.as.Date[i] - align.to));
}
# The corrected earliest follow-up window date:
correct.earliest.followup.window <- as.numeric(min(cma$data$.DATE.as.Date - min(cmas$.FU.START.DATE,na.rm=TRUE),na.rm=TRUE));
} else
{
# There is no correction to the earliest follow-up window date:
correct.earliest.followup.window <- 0;
}
# Compute the duration if not given:
if( is.na(duration) )
{
latest.date <- max(cma$data$.DATE.as.Date + cma$data[,cma$event.duration.colname], cmas$.FU.END.DATE, cmas$.OBS.END.DATE, na.rm=TRUE);
if( "end" %in% names(cmas) ) latest.date <- max(cmas$end, latest.date, na.rm=TRUE);
duration <- as.numeric(latest.date - earliest.date) + ifelse(align.first.event.at.zero, correct.earliest.followup.window, 0);
}
endperiod <- duration;
#
# Reserve plotting space for various components ####
#
# There may be a difference between patids and plotids, depending on the medication groups being defined or not:
if( !cma.mg )
{
plotids <- patids;
} else
{
plotids <- unique(patmgids[, col.plotid]);
}
# Reserve space for the CMA plotting:
adh.plot.space <- c(0, ifelse( plot.CMA && has.estimated.CMA, duration*CMA.plot.ratio, 0) );
duration.total <- duration + adh.plot.space[2];
# Make sure there's enough space to actually plot the plot IDs on the y-axis:
id.labels <- do.call(rbind,lapply(as.character(plotids), # for each plot ID, compute the string dimensions in inches
function(p)
{
# The participant axis text:
pid <- ifelse( print.CMA &&
!is.cma.TS.or.SW &&
has.estimated.CMA &&
length(x <- which(cmas[col.plotid] == p))==1,
paste0(p,"\n",sprintf("%.1f%%",cmas[x,"CMA"]*100)),
p);
data.frame("ID"=p,
"string"=pid,
"width"=strwidth(pid, units="inches", cex=cex.axis),
"height"=strheight(pid, units="inches", cex=cex.axis));
}));
y.label <- data.frame("string"=(tmp <- ifelse(is.null(ylab),"",
ifelse(length(ylab)==1,
ylab,
ifelse((print.CMA || plot.CMA) &&
has.estimated.CMA,
ylab["withCMA"],
ylab["withoutCMA"])))), # space needed for the label (in inches)
"width"=strwidth(tmp, units="inches", cex=cex.lab),
"height"=strheight(tmp, units="inches", cex=cex.lab));
left.margin <- (cur.mai <- par("mai"))[2]; # left margin in inches (and cache the current margins too)
if( .do.R ) # Rplot:
{
# Save the graphical params and restore them later:
old.par <- par(no.readonly=TRUE);
# Rotate the ID labels:
new.left.margin <- (y.label$height + (cos(-rotate.text*pi/180) * max(id.labels$width,na.rm=TRUE)) + strwidth("0000", units="inches", cex=cex.axis)); # ask for enough space
par(mai=c(cur.mai[1], new.left.margin, cur.mai[3], cur.mai[4]));
}
## Vertical space needed by the events ####
vert.space.events <- ifelse(plot.events.vertically.displaced, # are the events for the same patient displayed on different rows?
nrow(cma$data), # if yes, we need space for all individual events
length(unique(cma$data[,col.plotid]))); # otherwise, we only needs space for each patient
# Vertical space needed for showing the partial CMAs:
vert.space.cmas <- 0;
if( is.cma.TS.or.SW )
{
# There actually is a partial CMA to be potentially plotted:
if( ("timeseries" %in% plot.partial.CMAs.as) && (plot.partial.CMAs.as.timeseries.vspace < 5) )
{
if( !suppress.warnings ) .report.ewms(paste0("The minimum vertical space for the timeseries plots (plot.partial.CMAs.as.timeseries.vspace) is 5 lines, but it currently is only ",
plot.partial.CMAs.as.timeseries.vspace,
": skipping timeseries plots...\n"), "warning", ".plot.CMAs", "AdhereR");
plot.partial.CMAs.as <- plot.partial.CMAs.as[ plot.partial.CMAs.as != "timeseries" ];
}
vert.space.cmas <- vert.space.cmas +
ifelse(has.estimated.CMA,
(nrow(cmas)+length(plotids)) * as.numeric("stacked" %in% plot.partial.CMAs.as) +
3 * length(plotids) * as.numeric("overlapping" %in% plot.partial.CMAs.as) +
plot.partial.CMAs.as.timeseries.vspace * length(plotids) * as.numeric("timeseries" %in% plot.partial.CMAs.as),
0);
}
# Vertical space needed for the x axis:
x.label <- ifelse(is.null(xlab), # x axis label
"",
ifelse(length(xlab)==1,
xlab,
xlab[show.period]));
date.labels <- NULL;
if( period.in.days > 0 )
{
xpos <- seq(0, as.numeric(endperiod), by=period.in.days); # where to put lables and guidelines
if( show.period=="dates" )
{
axis.labels <- as.character(earliest.date + round(xpos, 1), format=cma$date.format);
} else
{
axis.labels <- as.character(round(xpos - ifelse(align.first.event.at.zero, correct.earliest.followup.window, 0), 1));
}
date.labels <- data.frame("position"=adh.plot.space[2] + xpos, "string"=axis.labels);
}
#
# SVG definitions and setup ####
#
if( .do.SVG ) # SVG:
{
# Compute the needed size:
# the idea is to assume 1 standard character (chr) == 16 user units, and 1 month (x axis) == 1 event (y axis) == 1 chr
# for the title, axis ticks and labels: 1 title == 1.5 chr, 1 axis tick == 0.75 chr, 1 axis label = 1.0 chr
# plus spacing of about 0.5 chr around elements
dims.chr.std <- 10; # the "standard" character size (SVG defaults to 16)
dims.chr.event <- dims.chr.std / 2;
dims.chr.title <- (cex.title * dims.chr.std);
dims.chr.axis <- (cex.axis * dims.chr.std);
dims.chr.lab <- (cex.lab * dims.chr.std);
dims.chr.cma <- (CMA.cex * dims.chr.std);
dims.chr.legend <- (legend.cex * dims.chr.std);
dims.chr.legend.title <- (legend.cex.title * dims.chr.std);
dims.event.x <- dims.chr.std*2; # the horizontal size of an event
dims.event.y <- (cex * dims.chr.std); # the vertical size of an event
dims.day <- ifelse(duration.total <= 90, 1, ifelse(duration.total <= 365, 7, ifelse(duration.total <= 3*365, 30, ifelse(duration.total <= 10*365, 90, 180)))); # how many days correspond to one horizontal user unit (depends on how many days there are in total)
dims.axis.x <- dims.chr.std + dims.chr.lab +
(cos(-rotate.text*pi/180) * max(vapply(as.character(date.labels$string), function(s) .SVG.string.dims(s, font_size=dims.chr.axis)["width"], numeric(1)),na.rm=TRUE));
dims.axis.y <- dims.chr.std + dims.chr.lab +
(sin(-rotate.text*pi/180) * max(vapply(as.character(id.labels$string), function(s) .SVG.string.dims(s, font_size=dims.chr.axis)["width"], numeric(1)),na.rm=TRUE));
dims.plot.x <- (dims.axis.y + dims.chr.std);
dims.plot.y <- (dims.chr.title + dims.chr.std);
dims.plot.width <- (dims.event.x * (duration.total + 10)/dims.day);
dims.plot.height <- (dims.event.y * (vert.space.events+vert.space.cmas+1));
# For the legend, we force a call to the .legend.SVG() to get the legend needed size:
if( !show.legend )
{
dims.legend.width <- 0; # no legend to show
dims.legend.height <- 0;
} else
{
.last.cma.plot.info <- list(); # create a fake .last.cma.plot.info because .legend.SVG() stores the results in it (it will be re-created later)
.legend.SVG(legend.x, legend.y, do.plot=FALSE); # estimate the needed spaces
dims.legend.width <- (.last.cma.plot.info$SVG$legend$box$x.end + dims.chr.std); # retrieve the right-most and top-most corner of the legend
dims.legend.height <- (.last.cma.plot.info$SVG$legend$box$y.end - .last.cma.plot.info$SVG$legend$box$y.start + dims.chr.std);
}
# Total size needed:
dims.total.width <- (dims.plot.x + max(dims.plot.width, dims.legend.width));
dims.total.height <- (dims.plot.y + max(dims.plot.height, dims.legend.height) + dims.axis.x);
# Do we need to adjust for an extra large legend?
dims.adjust.for.tall.legend <- max(0, dims.legend.height - dims.plot.height);
# Scaling functions for plotting within the SVG:
# Cache stuff:
dims.event.x.2.dims.day <- (dims.event.x / dims.day);
dims.plot.y.dims.plot.height.dims.adjust.for.tall.legend <- (dims.plot.y + dims.plot.height + dims.adjust.for.tall.legend);
.scale.width.to.SVG.plot <- function(w)
{
return (dims.event.x.2.dims.day * w);
}
.scale.x.to.SVG.plot <- function(x)
{
return (dims.plot.x + .scale.width.to.SVG.plot(x));
}
.scale.height.to.SVG.plot <- function(h)
{
return (h * dims.event.y);
}
.scale.y.to.SVG.plot <- function(y)
{
return (dims.plot.y.dims.plot.height.dims.adjust.for.tall.legend - .scale.height.to.SVG.plot(y));
}
# Stroke dash-arrays for line types (lty):
svg.stroke.dasharrays <- data.frame("lty"=0:6,
"names"=c("blank",
"solid",
"dashed",
"dotted",
"dotdash",
"longdash",
"twodash"),
"svg"=c(' fill="none" stroke="none" ',
' fill="none" ',
' fill="none" stroke-dasharray="3,3" ',
' fill="none" stroke-dasharray="1,2" ',
' fill="none" stroke-dasharray="1,2,3,2" ',
' fill="none" stroke-dasharray="5,2" ',
' fill="none" stroke-dasharray="2,2,4,2" '),
stringsAsFactors=FALSE);
# SVG header:
svg.str[[length(svg.str)+1]] <- c('<svg ',
'viewBox="0 0 ',dims.total.width,' ',dims.total.height,'" ',
' version="1.1" xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink">\n'); # the plotting surface
# Comments, notes and clarifications:
svg.str[[length(svg.str)+1]] <- c(.SVG.comment("This is the self-contained SVG plot.", newpara=TRUE),
.SVG.comment("NOTE: due to compatibility issues with Internet Explorer, we use explicit closing tags."));
# Reusable bits:
dce1 <- .SVG.number(dims.chr.event); dce2 <- .SVG.number(dims.chr.event/2); ndce2 <- .SVG.number(-dims.chr.event/2); dce3 <- .SVG.number(dims.chr.event/3); dce4 <- .SVG.number(dims.chr.event/4); # cache the various relative sizes used to draw the pch symbols
svg.str[[length(svg.str)+1]] <- list(
# Predefined things to be used in the drawing:
'<defs>\n',
# The point symbols (pch) used for events etc:
# (we use explicit tag closing as otherwise Internet Explorer generates warning HTML1500)
# pch 0:
'<g id="pch0" fill="none" stroke-width="1"> <rect x="',ndce2,'" y="',ndce2,'" width="',dce1,'" height="',dce1,'"></rect> </g>\n',
# pch 1:
'<g id="pch1" fill="none" stroke-width="1"> <circle cx="0" cy="0" r="',dce2,'"></circle> </g>\n',
# pch 2:
'<g id="pch2" fill="none" stroke-width="1"> <polyline points="',ndce2,',',dce2,' 0,',ndce2,' ',dce2,',',dce2,' ',ndce2,',',dce2,'"></polyline> </g>\n',
# pch 3:
'<g id="pch3" fill="none" stroke-width="1"> <line x1="',ndce2,'" y1="0" x2="',dce2,'" y2="0"></line> <line x1="0" y1="',ndce2,'" x2="0" y2="',dce2,'"></line> </g>\n',
# pch 4:
'<g id="pch4" fill="none" stroke-width="1"> <line x1="',ndce2,'" y1="',dce2,'" x2="',dce2,'" y2="',ndce2,'"></line> <line x1="',ndce2,'" y1="',ndce2,'" x2="',dce2,'" y2="',dce2,'"></line> </g>\n',
# pch 5:
'<g id="pch5" fill="none" stroke-width="1"> <polyline points="',ndce2,',0 0,',ndce2,' ',dce2,',0 0,',dce2,' ',ndce2,',0"></polyline> </g>\n',
# pch 6:
'<g id="pch6" fill="none" stroke-width="1"> <polyline points="',ndce2,',',ndce2,' 0,',dce2,' ',dce2,',',ndce2,' ',ndce2,',',ndce2,'"></polyline> </g>\n',
# pch 7:
'<g id="pch7" fill="none" stroke-width="1"> <use xlink:href="#pch0"></use> <use xlink:href="#pch4"></use> </g>\n',
# pch 8:
'<g id="pch8" fill="none" stroke-width="1"> <use xlink:href="#pch3"></use> <use xlink:href="#pch4"></use> </g>\n',
# pch 9:
'<g id="pch9" fill="none" stroke-width="1"> <use xlink:href="#pch3"></use> <use xlink:href="#pch5"></use> </g>\n',
# pch 10:
'<g id="pch10" fill="none" stroke-width="1"> <use xlink:href="#pch3"></use> <use xlink:href="#pch1"></use> </g>\n',
# pch 11:
'<g id="pch11" fill="none" stroke-width="1"> <use xlink:href="#pch2"></use> <use xlink:href="#pch6"></use> </g>\n',
# pch 12:
'<g id="pch12" fill="none" stroke-width="1"> <use xlink:href="#pch0"></use> <use xlink:href="#pch3"></use> </g>\n',
# pch 13:
'<g id="pch13" fill="none" stroke-width="1"> <use xlink:href="#pch1"></use> <use xlink:href="#pch4"></use> </g>\n',
# pch 14:
'<g id="pch14" fill="none" stroke-width="1"> <use xlink:href="#pch0"></use> <use xlink:href="#pch2"></use> </g>\n',
# pch 15:
'<g id="pch15" stroke-width="1"> <rect x="',ndce2,'" y="',ndce2,'" width="',dce1,'" height="',dce1,'"></rect> </g>\n',
# pch 16:
'<g id="pch16" stroke-width="1"> <circle cx="0" cy="0" r="',dce3,'"></circle> </g>\n',
# pch 17:
'<g id="pch17" stroke-width="1"> <polyline points="',ndce2,',',dce2,' 0,',ndce2,' ',dce2,',',dce2,' ',ndce2,',',dce2,'"></polyline> </g>\n',
# pch 18:
'<g id="pch18" stroke-width="1"> <polyline points="',ndce2,',0 0,',ndce2,' ',dce2,',0 0,',dce2,' ',ndce2,',0"></polyline> </g>\n',
# pch 19:
'<g id="pch19" stroke-width="1"> <circle cx="0" cy="0" r="',dce2,'"></circle> </g>\n',
# pch 20:
'<g id="pch20" stroke-width="1"> <circle cx="0" cy="0" r="',dce4,'"></circle> </g>\n',
# pch 26 ( < ):
'<g id="pch26" fill="none" stroke-width="1"> <polyline points="0,',dce2,' ',ndce2,',0 0,',ndce2,' "></polyline> </g>\n',
# pch 27 ( > ):
'<g id="pch27" fill="none" stroke-width="1"> <polyline points="0,',dce2,' ',dce2,',0 0,',ndce2,' "></polyline> </g>\n',
# pch 28 ( | ):
'<g id="pch28" fill="none" stroke-width="1"> <line x1="0" y1="',dce2,'" x2="0" y2="',ndce2,'"></line> </g>\n',
'</defs>\n',
'\n');
}
#
# The actual plotting ####
#
# For speed and clarity, we use an internal version of .last.cma.plot.info, which we save into the external environment on exit...
.last.cma.plot.info <- list("baseR"=NULL, "SVG"=NULL); # delete the previous plot info and replace it with empty info...
if( .do.R ) # Rplot:
{
# The plotting area:
if(inherits(msg <- try(plot( 0, 1,
xlim=c(0-5,duration.total+5), # pad left and right by 5 days to improve plotting
xaxs="i",
ylim=c(0,vert.space.events+vert.space.cmas+1),
yaxs="i",
type="n",
axes=FALSE,
xlab="",
ylab="" ),
silent=TRUE),
"try-error"))
{
# Some error occurred when creating the plot...
if( !suppress.warnings ) .report.ewms(msg, "error", ".plot.CMAs", "AdhereR");
try(par(old.par), silent=TRUE); # restore graphical params
#assign(".last.cma.plot.info", .last.cma.plot.info, envir=.adherer.env); # save the plot infor into the environment
plot.CMA.error(export.formats=export.formats,
export.formats.fileprefix=export.formats.fileprefix,
export.formats.directory=export.formats.directory,
generate.R.plot=generate.R.plot);
return (invisible(NULL));
}
# Make sure we're initially plotting on white:
par(bg="white");
# Character width and height in the current plotting system:
if( print.dose ) dose.text.height <- strheight("0",cex=cex.dose);
if( print.episode.or.sliding.window ) epiwnd.text.height <- strheight("0",cex=cex.dose);
char.width <- strwidth("O",cex=cex); char.height <- strheight("O",cex=cex);
char.height.CMA <- strheight("0",cex=CMA.cex);
# Minimum plot dimensions:
if( abs(par("usr")[2] - par("usr")[1]) <= char.width * min.plot.size.in.characters.horiz ||
abs(par("usr")[4] - par("usr")[3]) <= char.height * min.plot.size.in.characters.vert * (vert.space.events + ifelse(is.cma.TS.or.SW && has.estimated.CMA, nrow(cmas), 0)) )
{
if( !suppress.warnings ) .report.ewms(paste0("Plotting area is too small (it must be at least ",
min.plot.size.in.characters.horiz,
" x ",
min.plot.size.in.characters.vert,
" characters per patient, but now it is only ",
round(abs(par("usr")[2] - par("usr")[1]) / char.width,1),
" x ",
round(abs(par("usr")[4] - par("usr")[3]) / (char.height * (vert.space.events +
ifelse(is.cma.TS.or.SW && has.estimated.CMA, nrow(cmas), 0))),1),
")!\n"), "error", ".plot.CMAs", "AdhereR");
par(old.par); # restore graphical params
#assign(".last.cma.plot.info", .last.cma.plot.info, envir=.adherer.env); # save the plot infor into the environment
plot.CMA.error(export.formats=export.formats,
export.formats.fileprefix=export.formats.fileprefix,
export.formats.directory=export.formats.directory,
generate.R.plot=generate.R.plot);
return (invisible(NULL));
}
if( abs(par("usr")[2] - par("usr")[1]) / duration.total < 1.0 && !suppress.warnings ) .report.ewms("The horizontal plotting space might be too small!", "warning", ".plot.CMAs", "AdhereR");
if( abs(par("usr")[4] - par("usr")[3]) / (vert.space.events + ifelse(is.cma.TS.or.SW && has.estimated.CMA, nrow(cmas), 0)) < 1.0 && !suppress.warnings ) .report.ewms("The vertical plotting space might be too small!", "warning", ".plot.CMAs", "AdhereR");
# Save plot info:
.last.cma.plot.info$baseR <- list(
# Function params:
"patients.to.plot"=patients.to.plot,
"align.all.patients"=align.all.patients, "align.first.event.at.zero"=align.first.event.at.zero,
"show.period"=show.period,
"period.in.days"=period.in.days,
"show.legend"=show.legend, "legend.x"=legend.x, "legend.y"=legend.y,
"legend.bkg.opacity"=legend.bkg.opacity, "legend.cex"=legend.cex, "legend.cex.title"=legend.cex.title,
"cex"=cex, "cex.axis"=cex.axis, "cex.lab"=cex.lab, "cex.title"=cex.title,
"show.cma"=show.cma,
"xlab"=xlab, "ylab"=ylab,
"title"=title,
"col.cats"=col.cats, "unspecified.category.label"=unspecified.category.label,
"medication.groups.to.plot"=medication.groups.to.plot,
"lty.event"=lty.event, "lwd.event"=lwd.event, "pch.start.event"=pch.start.event, "pch.end.event"=pch.end.event,
"show.event.intervals"=show.event.intervals,
"print.dose"=print.dose, "cex.dose"=cex.dose, "print.dose.col"=print.dose.col, "print.dose.centered"=print.dose.centered,
"print.episode.or.sliding.window"=print.episode.or.sliding.window,
"plot.dose"=plot.dose, "lwd.event.max.dose"=lwd.event.max.dose, "plot.dose.lwd.across.medication.classes"=plot.dose.lwd.across.medication.classes,
"col.na"=col.na, "col.continuation"=col.continuation, "lty.continuation"=lty.continuation, "lwd.continuation"=lwd.continuation,
"print.CMA"=print.CMA, "CMA.cex"=CMA.cex,
"plot.CMA"=plot.CMA, "plot.CMA.as.histogram"=plot.CMA.as.histogram,
"plot.partial.CMAs.as"=plot.partial.CMAs.as,
"plot.partial.CMAs.as.stacked.col.bars"=plot.partial.CMAs.as.stacked.col.bars,
"plot.partial.CMAs.as.stacked.col.border"=plot.partial.CMAs.as.stacked.col.border,
"plot.partial.CMAs.as.stacked.col.text"=plot.partial.CMAs.as.stacked.col.text,
"plot.partial.CMAs.as.timeseries.vspace"=plot.partial.CMAs.as.timeseries.vspace,
"plot.partial.CMAs.as.timeseries.start.from.zero"=plot.partial.CMAs.as.timeseries.start.from.zero,
"plot.partial.CMAs.as.timeseries.col.dot"=plot.partial.CMAs.as.timeseries.col.dot,
"plot.partial.CMAs.as.timeseries.col.interval"=plot.partial.CMAs.as.timeseries.col.interval,
"plot.partial.CMAs.as.timeseries.col.text"=plot.partial.CMAs.as.timeseries.col.text,
"plot.partial.CMAs.as.timeseries.interval.type"=plot.partial.CMAs.as.timeseries.interval.type,
"plot.partial.CMAs.as.timeseries.lwd.interval"=plot.partial.CMAs.as.timeseries.lwd.interval,
"plot.partial.CMAs.as.timeseries.alpha.interval"=plot.partial.CMAs.as.timeseries.alpha.interval,
"plot.partial.CMAs.as.timeseries.show.0perc"=plot.partial.CMAs.as.timeseries.show.0perc,
"plot.partial.CMAs.as.timeseries.show.100perc"=plot.partial.CMAs.as.timeseries.show.100perc,
"plot.partial.CMAs.as.overlapping.alternate"=plot.partial.CMAs.as.overlapping.alternate,
"plot.partial.CMAs.as.overlapping.col.interval"=plot.partial.CMAs.as.overlapping.col.interval,
"plot.partial.CMAs.as.overlapping.col.text"=plot.partial.CMAs.as.overlapping.col.text,
"CMA.plot.ratio"=CMA.plot.ratio,
"CMA.plot.col"=CMA.plot.col, "CMA.plot.border"=CMA.plot.border, "CMA.plot.bkg"=CMA.plot.bkg, "CMA.plot.text"=CMA.plot.text,
"highlight.followup.window"=highlight.followup.window, "followup.window.col"=followup.window.col,
"highlight.observation.window"=highlight.observation.window,
"observation.window.col"=observation.window.col,
"observation.window.opacity"=observation.window.opacity,
"show.real.obs.window.start"=show.real.obs.window.start,
"alternating.bands.cols"=alternating.bands.cols,
"rotate.text"=rotate.text,
"bw.plot"=bw.plot,
"min.plot.size.in.characters.horiz"=min.plot.size.in.characters.horiz, "min.plot.size.in.characters.vert"=min.plot.size.in.characters.vert,
"export.formats"=export.formats, "export.formats.fileprefix"=export.formats.fileprefix, "export.formats.directory"=export.formats.directory,
"generate.R.plot"=generate.R.plot,
# Computed things:
"old.par"=old.par,
"used.par"=par(no.readonly=TRUE),
"xlim"=c(0-5,duration.total+5), "ylim"=c(0,vert.space.events+vert.space.cmas+1),
"x.min"=0, "x.max"=duration.total, "y.min"=1, "y.max"=vert.space.events+vert.space.cmas,
"dose.text.height"=ifelse(print.dose, dose.text.height, NA),
"epiwnd.text.height"=ifelse(print.episode.or.sliding.window, epiwnd.text.height, NA),
"char.width"=char.width, "char.height"=char.height,
"char.height.CMA"=char.height.CMA,
"is.cma.TS.or.SW"=is.cma.TS.or.SW, "has.estimated.CMA"=has.estimated.CMA,
"cma"=cma, "cmas"=cmas,
"categories"=categories, "cols"=cols, ".map.category.to.color"=.map.category.to.color,
"earliest.date"=earliest.date, "correct.earliest.followup.window"=correct.earliest.followup.window, "endperiod"=endperiod,
"adh.plot.space"=adh.plot.space, "duration.total"=duration.total,
"id.labels"=id.labels, "date.labels"=date.labels, "x.label"=x.label, "y.label"=y.label,
"vert.space.cmas"=vert.space.cmas
);
if(plot.dose || print.dose)
{
.last.cma.plot.info$baseR$dose.range <- dose.range;
if( plot.dose.lwd.across.medication.classes ) .last.cma.plot.info$baseR$dose.range.global <- dose.range.global;
.last.cma.plot.info$baseR$adjust.dose.lwd <- adjust.dose.lwd;
}
}
if( .do.SVG ) # SVG:
{
svg.str[[length(svg.str)+1]] <- list(
# Clear the area:
.SVG.rect(comment="Clear the whole plotting area",
class="plotting-area-background",
x=0, y=0, width=dims.total.width, height=dims.total.height,
fill="white", stroke="none"),
'\n' # one empty line
);
# Save plot info:
.last.cma.plot.info$SVG <- list(
# Function params:
"patients.to.plot"=patients.to.plot,
"align.all.patients"=align.all.patients, "align.first.event.at.zero"=align.first.event.at.zero,
"show.period"=show.period,
"period.in.days"=period.in.days,
"show.legend"=show.legend, "legend.x"=legend.x, "legend.y"=legend.y,
"legend.bkg.opacity"=legend.bkg.opacity, "legend.cex"=legend.cex, "legend.cex.title"=legend.cex.title,
"cex"=cex, "cex.axis"=cex.axis, "cex.lab"=cex.lab, "cex.title"=cex.title,
"show.cma"=show.cma,
"xlab"=xlab, "ylab"=ylab,
"title"=title,
"col.cats"=col.cats, "unspecified.category.label"=unspecified.category.label,
"medication.groups.to.plot"=medication.groups.to.plot,
"lty.event"=lty.event, "lwd.event"=lwd.event, "pch.start.event"=pch.start.event, "pch.end.event"=pch.end.event,
"show.event.intervals"=show.event.intervals,
"print.dose"=print.dose, "cex.dose"=cex.dose, "print.dose.col"=print.dose.col, "print.dose.centered"=print.dose.centered,
"print.episode.or.sliding.window"=print.episode.or.sliding.window,
"plot.dose"=plot.dose, "lwd.event.max.dose"=lwd.event.max.dose, "plot.dose.lwd.across.medication.classes"=plot.dose.lwd.across.medication.classes,
"col.na"=col.na, "col.continuation"=col.continuation, "lty.continuation"=lty.continuation, "lwd.continuation"=lwd.continuation,
"print.CMA"=print.CMA, "CMA.cex"=CMA.cex,
"plot.CMA"=plot.CMA, "plot.CMA.as.histogram"=plot.CMA.as.histogram,
"plot.partial.CMAs.as"=plot.partial.CMAs.as,
"plot.partial.CMAs.as.stacked.col.bars"=plot.partial.CMAs.as.stacked.col.bars,
"plot.partial.CMAs.as.stacked.col.border"=plot.partial.CMAs.as.stacked.col.border,
"plot.partial.CMAs.as.stacked.col.text"=plot.partial.CMAs.as.stacked.col.text,
"plot.partial.CMAs.as.timeseries.vspace"=plot.partial.CMAs.as.timeseries.vspace,
"plot.partial.CMAs.as.timeseries.start.from.zero"=plot.partial.CMAs.as.timeseries.start.from.zero,
"plot.partial.CMAs.as.timeseries.col.dot"=plot.partial.CMAs.as.timeseries.col.dot,
"plot.partial.CMAs.as.timeseries.col.interval"=plot.partial.CMAs.as.timeseries.col.interval,
"plot.partial.CMAs.as.timeseries.col.text"=plot.partial.CMAs.as.timeseries.col.text,
"plot.partial.CMAs.as.timeseries.interval.type"=plot.partial.CMAs.as.timeseries.interval.type,
"plot.partial.CMAs.as.timeseries.lwd.interval"=plot.partial.CMAs.as.timeseries.lwd.interval,
"plot.partial.CMAs.as.timeseries.alpha.interval"=plot.partial.CMAs.as.timeseries.alpha.interval,
"plot.partial.CMAs.as.timeseries.show.0perc"=plot.partial.CMAs.as.timeseries.show.0perc,
"plot.partial.CMAs.as.timeseries.show.100perc"=plot.partial.CMAs.as.timeseries.show.100perc,
"plot.partial.CMAs.as.overlapping.alternate"=plot.partial.CMAs.as.overlapping.alternate,
"plot.partial.CMAs.as.overlapping.col.interval"=plot.partial.CMAs.as.overlapping.col.interval,
"plot.partial.CMAs.as.overlapping.col.text"=plot.partial.CMAs.as.overlapping.col.text,
"CMA.plot.ratio"=CMA.plot.ratio,
"CMA.plot.col"=