Recently Published
VOLKAN OBAN
R artsy package
R
VOLKAN OBAN
aRtsy
R
aRtsy
R
VOLKAN OBAN
aRtsy pckage
R
sin(x/tan(cos(x)))-exp(-sin(x))
R
ref: https://github.com/marcusvolz
aRt with mathematics
{tan(cos(x/x^3+3)/sin(x/x^3+1)-x^4)}
Plotting using complex functions
z^5+(-0.2+0.11*1i)/z^10
Plotting using complex functions
z^5+(-0.2+0.11*1i)/z^3
Plotting using complex functions
z^5+(-0.2+0.11*1i)/z^9
Plotting using complex functions
z^3+(-0.2+0.11*1i)/z^3
Plotting using complex functions
1+ z+z^2-0.8/z^3
VOLKAN OBAN
18,350,0.43,120,0.45,0.817,-0,12
art with mathematical functions
sin(cos(tan(exp(2-x))))
art with mathematical functions
12,250,0.41,110,0.25,1.817,-0.025
function(x) {cos(1/1+sin(x)+1/1+sin(x)*sin(x))}
aRt
sin(sin(cos((exp(1/x)/1+x^2)))/1+x^exp(-x^1/x^2))
art with mathematical functions
sin(cos(sin(x/1+x^4))/x+x^exp(-x^2/x))
aRt with mathematics
sin(sin(cos(x))/1+x^exp(-x^1/x))
aRt with mathematics
sin(x/1+x^exp(-x^1/x))
2.75
-0.25
aRt with mathematics
sin(1/1+x^exp(-x^1/x))
aRt
sin(exp(-1/cos(x/x^7+3)/x^9))
aRt with mathematics
sin(exp(-1/cos(x/x^7+3)/x^7))
aRt with mathematics
12
205
0.22
102 #
0.87 0.15
-0.28
{sin(cos(x/x^3+3)/sin(x/x^3+1)-x^4)}
aRt with mathematics
sin(cos(x+5*x*x/x^4+3)/sin(x/x^4+1)-x^3)
Plot
8
210
0.22
105
0.45
0.12
{sin(cos(x+5*x*x/3)/sin(x/x+1)-x^3)}
aRt with mathematics
sin(cos(2*sin(exp(x^sin(1/x^4)))))
art with mathematical functions
cos(2*sin(exp(x^sin(1/x^4))))
aRt with mathematics
cos(x*sin(exp(x^sin(1/x^2))))
art with mathematical functions
cos(x*sin(exp(x^sin(1/x^2)))
aRt with mathematics
cos(2*sin(exp(x^sin(x))))
Roses-art with mathematical functions
12
300
0.32
400
0.4
0.75
line_color <- "white"
back_color <- "black"
{sinh(log(x+1)*cos(x)*sin(1/x))}
R
{cos(sin(exp(-x^2))/x^3)}
aRt with mathematics
{cos(sin(exp(-x^2))/x^4)}
aRt with mathematics
cos(sin(exp(-x^2))/x^4)
aRt with mathematics
cos(x^4*x-sin(cos(1/x^4)))
art with mathematical functions
{sin(cos(1/x^4))}
aRt with mathematics
{sin(cos(1/x^4))}
R
sin(x^sin(cos(x)))
aRt
x^sin(cos(x))
R
1/x^4*sin(x)
R
{tan(sin(cos(exp(x/x^2+1))))}
R aRT
tan(sin(cos(exp(x/x^2+1))))
R aRT
Elif
VOLKAN OBAN
Dr. VOLKAN OBAN
art with mathematical functions
sin(cos(sin(x*x)))
aRt with mathematics
cos(exp(-x)*sin(exp(-x)))
R
cos(exp(-x)*sin(exp(-x)))
art with mathematical functions
12,100,0.41,105,2,0.2,-0.05, {sin(x/(-cos(x)))}
R
{sin(2*x*x)^x*x-x/cos(x+tan(x+1))}
R aRT
{sin(2*x*x)^x*x-x/cos(x+tan(x+1))}
art with mathematical functions
{sin(x)^x*x-1/cos(x^9)}
aRt with mathematics
{sin(x)^x*x-1/cos(x^9)}
mathematics
{sin(x)^x*x-1/cos(x^9)}
art with mathematical functions
{sin(x)^x-1/cos(x^9)}
VOLKAN OBAN
{sin(x)^2/cos(x*x)}
aRt with mathematics
{sin(cos(log(4^x*2)))/x^4-1}
aRt with mathematics
sin(cos(log(2^x*x+1)))/x^2-1
art with mathematical functions
{sin(cos(x/log(2^x*x+1)))+1}
art with mathematical functions
sin(cos(log(2^2*x+1)))/x^2-1)
art with mathematical functions
{{sin(cos(x+5*x*x/3)/sin(x/x+1)-x^3)}}
aRt with mathematics
{{sin(cos(x+5*x*x/3)/sin(x/x+1)-x^3)}}
R
Dr. Volkan OBAN
aRt with mathematics
{{cos(x/3)/sin(x/x*x+1)-x^5}}
R aRT
{cos(x/4)/1-x^5}
art with mathematical functions
{cos(x/2)/1-x^5}
aRt with mathematics
{cos(x/2)/1-x^3}
R
{x^x-sin(x^3)^tan(x/cos(x))}
VOLKAN OBAN
cos(x/x+x^(exp(-x*x)))
VOLKAN OBAN
{cos(x/x+x^2*(exp(-x*x)))}
aRt with mathematics
12 300 - 0.43 110 0.65 0.817 - -0.09 {cos(3*x/x+sin(exp(-x*x)))}
mathematical functions
{cos(2*x/x+sin(exp(-x*x)))}
aRt with mathematics
{cos(2*x/x+sin(exp(-x*x)))}
mathematical functions
sin(x+x^5/cos(sin(x)/x+2*sin(exp(-x))))
mathematical functions
{cos(x/2)/1-x^3}
aRt with mathematics
{sin(-cos(1/1x*x)*x/x^11+2)}
aRt with mathematics
{sin(cos(x)*x/x^5+2)}
aRt with mathematics
sin(cos(x)*1/x^3+2)
Plot
AÇI<- 2.15
cos(x/x^2^x/x^6+2)
aRt with mathematics
{cos(x/x^2^x/x^6+2)}
6 # 300 0.43 110 0.65 0.67 -0.09
mathematical functions
function(x) {cos(x/x^2^x/x^4+2)}
R
math
volkan oban
mathematics
sin(tan(abs(2*x)/x+1))
volkan oban
{cos(x)^3*x/x^2+1}
mathematics
{cos(2*sin(x/exp(-x))^1/x^2+1)}
aRt with mathematics
tan(x)*x+cos(x^7)
mathematics
log(cos(x^5))
volkan oban
cos(exp(-x))^sin(x^2)/x^7-1
aRt with mathematics
cos(exp(-x))^x/x^5-1
aRt with mathematics
cos(exp(-x))^x/x^3-1
art with mathematical functions
cos(2*sin(1/1+tan(exp(-*x))))
art with mathematical functions
cos(2*sin(x/exp(-x))^1/x+1)
mathematical functions
{sin(x*x+2/cos(exp(-x))^-x/x+1)}
mathematical functions
sin(cos
art with mathematical functions
exp(-sin(exp(cos(x/1-x^5)/x*x*x)))
art with mathematical functions
{exp(-sin(exp(cos(x)/x*x)))}
aRt with mathematics
5,250,0.43, 110,0.32,8.9-0.0002
{exp(-sin(exp(1/x*x)))}
aRt with mathematics
exp(-sin(exp(1/x*x)))
aRt with mathematics
12,101,0.43, 110,0.84,8.817,-0.0002
{exp(-sin(exp(1/x*x)))}
art with mathematical functions
sin(-exp(cos(-1/x*x*x)))
mathematical functions
cos(exp(sin(cos(exp(sin(cos(x)))))))
volkan oban
cos(exp(sin(cos(exp(sin(cos(x)))))))
math and graph
exp(exp(exp(exp(-x))))
aRt with mathematics
exp(sin(x))
mathematics
exp(x+log(sin(cos(sin(-exp(x*x))))))
mathematical functions
exp(-x)^log(sin(cos(sin(-exp(x*x)))))
volkan oban
x^log(sin(cos(sin(-exp(x*x)))))
art with mathematical functions
cos(sin(exp(x)))
aRt with mathematics
{cos(sin(exp(-x)))}
aRt with mathematics
8,1000,0.32,500,0.4,0.75,-0,27
cos(x)*sin(1/x)*log(x+1)
art with mathematical functions
sin(cos(sin(cos(x*x))))
Plot
12
> niter <- 200 #
> p <- 0.43 #
> st <- 48
>a lf <- 0.78 e
> aci <-2.817
> cv <- -0.05
> line_color<- "white"
> back_color <- "black"
function(x) {cos(exp(-x)*sin(2*x))}
art with mathematical functions
cos(2*tan(sin(-4*x*x*cos(tan(1/x*x*x*x)))))
aRt with mathematics
tan(1/exp(cos(4*x)))
aRt with mathematics
tan(exp(-cos(4*x)))
aRt with mathematics
tan(-exp(cos(x)))
Plot
tan(2*x)+cos(2*x)+sin(2*x)
volkan oban
abs(sin(cos(1/x*x))*exp(1/x*x))
aRt with mathematics
abs(sin(cos(1/x*x))*exp(-1/x))
art with mathematical functions
abs(sin(cos(1/x)))
art with mathematical functions
tan(exp(2*-cos(factorial(sin(x)))))
mathematics
x-factorial(sin(x))/x^2
mathematics
factorial(cos(x))
mathematics
tan(exp(2*-cos(factorial(sin(x)))))
aRt with mathematics
exp(sin(1/x))
12
250
0.4
101
0.25
-1.52
art with mathematical functions
exp(cos((sin(-x*x))))
aRt with mathematics
cos(x*x)*tan(x*x)*sin(x*x)*(sin(x))^2
aRt with mathematics
log(x+1)*tan(2*x)*sin(2*x)*(sin(x))^2
math and graph
sin(cos(exp(cos(1-x*x))))
aRt with mathematics
tan(x*x*exp(-sin(x)*cos(1/x/x)))
aRt with mathematics
x+tan(2*sin(exp(-sin(x))))
aRt with mathematics
{tan(2*sin(exp(-sin(x))))}
aRt with mathematics
tan(exp(sin(x)*cos(x)))
aRt with mathematics by Volkan OBAN
ref: Chinchón
aRt with mathematics
Trigonometric functions
aRt with mathematics
sin(exp(x)+cos(x))
aRt with mathematics
ref: A.S. Chinchón
Johns Hopkins Covid-19 data
ref:https://joachim-gassen.github.io/
aRt with mathematics
{sin(1/cos(1+x))}
R volkan oban
{sin(-exp(cos(-1/x*x*x)))}
R
{sin(-exp(cos(-1/x*x*x)))}
aRt with mathematics
{cos(sinh(tan(-1/x)))+cosh(sin(x))}
R
{tan(sinh(x))}
aRt with mathematics
Volkan OBAN
aRt with mathematics
cos(sinh(tan(1/x)))
r volkan oban
function(x) {sinh((-cos(sin((1/x)+(1/x*x)+(1/x^3)+(1/x^4)+1))))}
R volkan oban
{sinh(cos((1/x)+(1/x*x)+(1/x^3)+(1/x^4)+1))}
R volkan oban
sinh((1/x)+(1/x*x)+(1/x^3)+(1/x^4))
aRt with mathematics
{1-cos(sinh(tan(sin(x))))/1-x}
R volkan oban
{x*cos(sinh(tan(sin(x))))/1-x}
aRt with mathematics
{cos(sinh(tan(sin(1-x))))}
aRt with mathematics
{cos(sinh(tan(sin(1-x))))}
aRt with mathematics
1-sinh(tan(sin(1-x)))
aRt with mathematics
{1-sinh(exp(-x))}
aRt with mathematics
{x+sinh(exp(-x))}
R volkan oban
sinh(cos(sin(exp(tan(cosh(x)/x*x)))))
R volkan oban
sinh(cos(sin(exp(tan(cosh(x)/x*x)))))
R volkan oban
{sin(exp(tan(-1/x*x)))
R volkan oban
{exp(tan(-1/x*x))}
R
{2*tan(1/x)-x}
R volkan oban
{2*x-x/cos(x)}
sem path
semPaths(fit,
+ sizeLat = 4, label.prop = 0.5, curve = 0.5, bg = "lightgreen", groups = "latents",
+ intercepts = FALSE, borders = FALSE, label.norm = "O")
> semPaths(fit,
+ sizeLat = 4, label.prop = 0.5, curve = 0.5, bg = "gold", groups = "latents",
+ intercepts = FALSE, borders = FALSE, label.norm = "O")
sem path
Structural Equation Modeling
aRt with mathematics
cos(1/x-exp(-4/x))
R volkan oban
{sin(sinh(x))}
aRt with mathematics
{cos(sin(x)-2*x)/x-log(x^5)}
R volkan oban
{cos(sin(x)-4*x)/x-log(x^5)}
aRt with mathematics
{cos(x)/x-log(x^5)}
aRt with mathematics
{1/x-log(x^3)
aRt with mathematics
{sin(tan(exp(sin(x)*cos(x-1))))}
aRt with mathematics
> edges <- 5 # Number of edges of the original polygon
> niter <- 300 # Number of iterations
> pond <- 0.43 # Weight to calculate the point on the middle of each edge
> step <- 101 # Number of times to draw mid-segments before connect ending points
> alph <- 0.25 # transparency of curves in geom_curve
> angle <- 0.817 # angle of mid-segment with the edge
> curv <- 0.197 # Curvature of curves
> line_color <- "white" # Color of curves in geom_curve
> back_color <- "black" # Background of the ggplot
> ratio_f <- function(x) {x+tan(exp(sin(x)*cos(x-1)))}
aRt
{x*(x+tan(exp(sin(x)*cos(x-1))))}
aRt with mathematics
{1/tan(1/exp(sin(cos(x))))+tan(cos(exp(-sin(x))))}
aRt with mathematics
VOLKAN OBAN
aRt with mathematics
tan(cos(exp(sin(x))))
aRt with mathematics
{sin(cos(exp(tan(x))))}
aRt with mathematics
function(x) {tan(sin(cos(1/x)))}
aRt with mathematics
{tan(sin(cos(x)))}
aRt with mathematics
function(x) {x+tan(exp(sin(x)*cos(x-1)))}
aRt with mathematics
function(x) {sin(x/4)}
aRt with mathematics
sin(x)/x-(cosh(exp(-sin(x))))}
aRt with mathematics
{sin(x)/x-(cosh(exp(-sin(x))))}
aRt with mathematics
{1/x-(cosh(exp(-cos(x))))}
aRt with mathematics
{1/x-(cosh(exp(-cos(x))))}
aRt with mathematics
1/x-(-sinh(exp(-cos(x))))
aRt with mathematics
{x-(-sinh(exp(-cos(x))))}
aRt with mathematics
1-(sinh(exp(cos(x))))
aRt with mathematics
{1-(-tan(exp(cos(x))))}
aRt with mathematics
{x/1-x-cos(x)*sin(tan(exp(cos(x/2))))}
flowers
log(x+1)*cos(x)*sin(1/x)
aRt with mathematics
-sin(x)*cos(x)*tan(x)
aRt with mathematics
function(x) {x/1-x-cos(x)*sin(-tan(exp(cos(x))))}
R
> library(tidyverse)
>
> # This function creates the segments of the original polygon
> polygon <- function(n) {
+ tibble(
+ x = accumulate(1:(n-1), ~.x+cos(.y*2*pi/n), .init = 0),
+ y = accumulate(1:(n-1), ~.x+sin(.y*2*pi/n), .init = 0),
+ xend = accumulate(2:n, ~.x+cos(.y*2*pi/n), .init = cos(2*pi/n)),
+ yend = accumulate(2:n, ~.x+sin(.y*2*pi/n), .init = sin(2*pi/n)))
+ }
>
> # This function creates segments from some mid-point of the edges
> mid_points <- function(d, p, a, i, FUN = ratio_f) {
+ d %>% mutate(
+ angle=atan2(yend-y, xend-x) + a,
+ radius=FUN(i),
+ x=p*x+(1-p)*xend,
+ y=p*y+(1-p)*yend,
+ xend=x+radius*cos(angle),
+ yend=y+radius*sin(angle)) %>%
+ select(x, y, xend, yend)
+ }
>
> # This function connect the ending points of mid-segments
> con_points <- function(d) {
+ d %>% mutate(
+ x=xend,
+ y=yend,
+ xend=lead(x, default=first(x)),
+ yend=lead(y, default=first(y))) %>%
+ select(x, y, xend, yend)
+ }
>
> edges <- 5 # Number of edges of the original polygon
> niter <-300 # Number of iterations
> pond <- 0.24 # Weight to calculate the point on the middle of each edge
> step <- 32 # Number of times to draw mid-segments before connect ending points
> alph <- 0.25 # transparency of curves in geom_curve
> angle <- 0.6 # angle of mid-segment with the edge
> curv <- 0.119 # Curvature of curves
> line_color <- "black" # Color of curves in geom_curve
> back_color <- "white" # Background of the ggplot
> ratio_f <- function(x) {1/sin(x)} # To calculate the longitude of mid-segments
>
> # Generation on the fly of the dataset
> accumulate(.f = function(old, y) {
+ if (y%%step!=0) mid_points(old, pond, angle, y) else con_points(old)
+ }, 1:niter,
+ .init=polygon(edges)) %>% bind_rows() -> df
>
> # Plot
> ggplot(df)+
+ geom_curve(aes(x=x, y=y, xend=xend, yend=yend),
+ curvature = curv,
+ color=line_color,
+ alpha=alph)+
+ coord_equal()+
+ theme(legend.position = "none",
+ panel.background = element_rect(fill=back_color),
+ plot.background = element_rect(fill=back_color),
+ axis.ticks = element_blank(),
+ panel.grid = element_blank(),
+ axis.title = element_blank(),
+ axis.text = element_blank())
aRt
> angle <- 6.2
> points <- 1000
>
> t <- (1:points)*2*angle
> x <- sin(-2*t)
> y <- cos(2*t)
>
> df <- data.frame(t, x, y)
R
> angle <- 4.2
> points <- 1000
>
> t <- (1:points)*2*angle
> x <-cos(t)
> y <-sin(t)
>
> df <- data.frame(t, x, y)
>
R
> angle <- 4.2
> points <- 1000
>
> t <- (1:points)*angle
> x <-sin(t)
> y <- cos(t)*(-1/t)
>
> df <- data.frame(t, x, y)
R
> angle <- 4.2
> points <- 1000
>
> t <- (1:points)*angle
> x <- t-exp(-1/t)
> y <- cos(1/t)-sin(t)
>
> df <- data.frame(t, x, y)
>
> p <- ggplot(df, aes(x*t, y*t))
> p + geom_point(aes(size = t), alpha = 0.72, color = "red", shape = 17) +theme(
+ plot.title = element_text(color = "black", size = 7, face = "bold"),
+ panel.grid = element_blank(),
+ legend.position = "none",
+ panel.background = element_rect(fill = "black"))
R
> angle <- 4.2
> points <- 1000
>
> t <- (1:points)*angle
> x <- t
> y <- cos(1/t-t)
>
> df <- data.frame(t, x, y)
>
R DataViz
> angle <- 3.2
> points <- 1000
>
> t <- (1:points)*angle
> x <- sin(t^3-t^2+t)
> y <- cos(1/t-t)
>
> df <- data.frame(t, x, y)
R
> angle <- 3.2
> points <- 600
>
> t <- (1:points)*angle
> x <- sin(t^3-t)
> y <- cos(1/t)
>
> df <- data.frame(t, x, y)
R DataViz
> angle <- 4.2
> points <- 1000
>
> t <- (1:points)*2*angle
> x <- sin(tan(2*t))
> y <- cos(tan(2*t))
>
R
> angle <- 4.2
> points <- 1000
>
> t <- (1:points)*2*angle
> x <- sin(2*t)
> y <- cos(2*t)
>
> df <- data.frame(t, x, y)
aRt with mathematics
function(x) {cos(x+x^3+x^7)-sin(x)}
mosaic
exp
> library(manipulate)
> plotFun(A *exp(-1/t)* cos(k*pi * t/P) * sin(2 * pi * t/P) ~ t + k, t.lim = range(0, 10),k.lim = range(-0.3,0), A = 10, P = 4, surface = TRUE)
aRt with mathematics
x*sin(x)-log(x)*cos(x)+1
aRt with mathematics
1-log(x)*[cos(x)*sin(x)*tan(x)/exp(x*x*x)]
aRt with mathematics
sin(x)+tan(x)/exp(x)
aRt with mathematics
1+cos(2*x)*log(x)*sin(x)
aRt with mathematics
1+x*log(x)*sin(x)
mathematical art
1-tan(2x)
aRt with mathematics
function(x) {x^2 -1 /x*sin(cos(sin(x)))*log(x+1)}
aRt with mathematics
function(x) {sin(x)/x*x}
aRt with mathematics
function(x) {(log(x+(x^2))*cos(sqrt(x))/exp((x^2)-1))+sin(1+x^3)+1-1/1-x}
aRt with mathematics
function(x) {(log(x+sqrt(x^5))*cos(sqrt(x))/exp((x^2)-1))+sin(1+x)+1+cos(x)
aRt with mathematics
• function(x) {(log(x+sqrt(x))*cos(x)/exp((x^3)-1))+sin(1+x)+1}
aRt with mathematics
• function(x) {(log(x)*cos(x)/exp((x^3)-1))+sin(1+x)+1}
aRt with mathematics
function(x) {(log(x)/exp((x^3)-1))+sin(1+x)}
aRt with mathematics
function(x) {(1/exp((x^3)-1))+sin(1+x)}
R
function(x) {x^3+sin(2*x)*cos(3/x)*log(2*x)+1/x-5*x}
ref:aschinchon
aRt
function(x) {x+cos(x*x-1)*sin(x*x-1)+(x-1)}
aRt with mathematics
function(x) {exp(cos(x*x-1))*sin(x*x*x)}
aRt with mathematics
function(x) {exp(cos(x*x-1))}
aRt with mathematics
function(x) {cos(x+1)*sin(x-1)-1/x-log(x)}
aRt with mathematics
function(x) {cos(x)*sin(x-1)-x*tan(1/x)+log(x)}
aRt with mathematics
function(x) {cos(x)*sin(x-1)-x}
R
function(x) {1/tan(-cos(sin(log(x*x/exp(-x^2)))))}
R
{tan(cos(sin(log(x*x/exp(-x^2))))}
R
function(x) {cos(sin(log10(x*x/500))/x}
R
function(x) {sin(log10(x*x/500))}
aRt with mathematics
log(5*x+1)*cos(3*x)*sin(1/x)
ggparty
ref: https://cran.r-project.org/web/packages/ggparty/vignettes/ggparty-graphic-partying.html
ggparty
ref:https://cran.r-project.org/web/packages/ggparty/vignettes/ggparty-graphic-partying.html
geometric shape
ref:Antonio Sánchez Chinchón
ggforce
ref: r-blogger
ggforce
ref: r- blogger
ggforce
ref : r blogger
network visualization
Network visualization in R.
library(igraph)
library(ggraph)
library(igraphdata)
library(smglr)
data: yeast
yeast protein interactions from igraphdata (only biggest component)
ref:https://lnkd.in/gasiqWz
chaos
ref: fronkonstin
chaos
ref:fronkonstin.com/category/chaos/
ggstatsplot
ggstatsplot
ggstatsplot
Package ‘ggstatsplot in R.
it supports only the most common types
of statistical tests: parametric, nonparametric, robust, and bayesian versions of t-test/anova, correlation analyses, contingency table analysis ,and regression analyses.
#R #volkanoban #statisticaltests #datascience #analytics #datavisualization
ref: cran.r-project.org
ggplot2
library(tidyverse)
> seq(from=-10, to=10, by = 0.05) %>%
+ expand.grid(x=., y=.) %>%
+ ggplot(aes(x=(x^2+0.5*pi*cos(y)^2), y=(y+0.5*pi*sin(x)))) +
+ geom_point(alpha=.1, shape=20, size=1, color="white")+
+ theme_void()+coord_fixed()
Plot
> theme <- theme(plot.title = element_text(hjust = 0.5), # Centered title
+ plot.background = element_rect(fill="blueviolet"), # Black background
+ panel.background = element_rect(fill="purple"), # Dark grey panel background
+ panel.grid.minor = element_line(color="blueviolet"), # Hide grid lines
+ panel.grid.major = element_line(color="blueviolet"), # Hide grid lines
+ axis.text = element_text(color="white"), # Make axis text white
+ title = element_text(color="white", face="bold"), # Make title white and bold.
+ legend.background = element_rect(fill="blueviolet"), # Make legend background black
+ legend.text = element_text(color="white"), # Make legend text white
+ legend.key = element_rect(fill="blueviolet", color="blueviolet"), #Squares/borders of legend black
+ legend.position = c(.9,.4)) # Coordinates. Top right = (1,1)
> ggplot(diamonds, aes(x=cut, y=price)) +
+ geom_boxplot(aes(color=clarity), fill=NA) +
+ scale_color_discrete(guide=F) +
+ facet_wrap(~clarity, ncol=2) + theme
ggplot2
thm <- theme(plot.title = element_text(hjust = 0.5), # Centered title
+ plot.background = element_rect(fill="black"), # Black background
+ panel.background = element_rect(fill="purple"), #
+ panel.grid.minor = element_line(color="black"), # Hide grid lines
+ panel.grid.major = element_line(color="black"), # Hide grid lines
+ axis.text = element_text(color="white"), # Make axis text white
+ title = element_text(color="white", face="bold"), # Make title white and bold.
+ legend.background = element_rect(fill="black"), # Make legend background black
+ legend.text = element_text(color="white"), # Make legend text white
+ legend.key = element_rect(fill="black", color="black")
DALEX
breakDown::HR_data
factoextra
fviz_silhouett
k-means Clustering
factoextra and clustering packages
grid,gridextra
ref:https://uc-r.github.io/kmeans_clustering
Plot
ggplot(surveys_complete, aes(x = species_id, y = hindfoot_length)) +
+ geom_boxplot() +
+ theme_wsj()
ggplot2
> ggplot(data = surveys_complete, mapping = aes(x = species_id, y = weight)) +
+ geom_boxplot(alpha = 0) +
+ geom_jitter(alpha = 0.3, color = "red")
dygraphs
ref: r-graph-gallery
Calendar Heatmap
ref: r-graph-gallery.com
Calendar Heatmap
ref:
r-graph-gallery
Calendar Heatmap
ref:r-graph-gallery
wordcloud2 package
wordcloud2(d, size =1 , minRotation = -pi/8, maxRotation = -pi/3, rotateRatio = 1)
wordcloud2 package
Happy new years
ggwordcloud
love….AŞK
network visualization
ref: data-to-viz.com
network visualization
ref: data-to-viz.com
Plot
library(network)
library(sna)
library(maps)
library(ggplot2)
aRt
ref:fronkonstin.com
aRt
ref : fronkonstin.com
Cannibus Curve
,ref: r-bloggers.com/cannibus-curve-with-ggplot2/
lime
ref:www.data-imaginist.com
factoextra NbClust
ref : http://www.sthda.com
factoextra NbClust
ref :http://www.sthda.com
factoextra NbClust
ref: http://www.sthda.com
rpart.plot
> par(bg='lavender')
> anova.model <- rpart(Mileage ~ ., data = cu.summary)
> rpart.plot(anova.model, box.palette = "GnYlRd",
+ shadow.col = "black",
)
stacked densities plot
ref : shinyapps.
Michael Lee
Plot
> par(bg='springgreen4')
> x <- seq(-10, 10, length = 80)
> y <- x
> f <- function(x, y) {r <- sqrt(x^2 + y^2); 10 * cos(2*r) / 2*r}
> z <- outer(x, y, f)
> persp(x, y, z,col='royalblue1')
ggplot2 and ggthemes
facet_wrap
Plot
v=2*pi*(3-sqrt(5))
> i=500
> ggplot(data.frame(r=sqrt(1:i),t=(1:n)*v),
+ aes(x=r*cos(t),y=r*sin(t)))+
+ geom_point(aes(x=0,y=0),
+ size=240,
+ colour="violetred")+
+ geom_point(aes(size=(n-r)),
+ shape=21,fill="black",
+ colour="purple")+
+ theme_void()+theme(legend.position="none")
Plot
ggplot(df, aes(x,y)) +
+ geom_polygon()+
+ theme_void() + ggtitle("by VOLKAN OBAN using R \n Data Scientist")
> d <- data.frame(x=3, y=3)
> for (i in 2:1000){
+ d[i,1] <- d[i-1,1]+((0.88)^i)*2*cos(2*i)
+ d[i,2] <- d[i-1,2]+((0.88)^i)*2*sin(2*i)
+ }
> ggplot(df, aes(x,y)) +
+ geom_polygon()
ggplot2
library(ggplot2)
library(grid)
# get data
download.file(url="http://www.naturalearthdata.com/http//www.naturalearthdata.com/download/110m/cultural/ne_110m_admin_0_countries.zip", "ne_110m_admin_0_countries.zip", "auto")
unzip("ne_110m_admin_0_countries.zip")
file.remove("ne_110m_admin_0_countries.zip")
# read shape file using rgdal library
library(rgdal)
ogrInfo(".", "ne_110m_admin_0_countries")
world <- readOGR(".", "ne_110m_admin_0_countries")
summary(world)
plot(world, col = "firebrick1")
art
ref: https://github.com/aschinchon
aRt
> seq(-3,3,by=.01) %>%
+ expand.grid(x=., y=.) %>%
+ ggplot(aes(x=(x^5-sin(y^2)), y=(y^5-cos(x^2)))) +
+ geom_point(alpha=.05, shape=20, size=0, color="white")+
+ theme_void()+
+ coord_fixed()+
+ theme(panel.background = element_rect(fill="darkred"))+
+ coord_polar()
aRt
library(tidyverse)
> seq(-3,3,by=.01) %>%
+ expand.grid(x=., y=.) %>%
+ ggplot(aes(x=(x^3-sin(y^2)), y=(y^3-cos(x^2)))) +
+ geom_point(alpha=.1, shape=20, size=0, color="white")+
+ theme_void()+
+ coord_fixed()+
+ theme(panel.background = element_rect(fill="purple"))+
+ coord_polar()
ref:
https://fronkonstin.com/
aRt
ref:https://fronkonstin.com/
aRt
df <- data.frame(x=0, y=0)
> for (i in 2:500){
+ df[i,1] <- df[i-1,1]+((0.98)^i)*cos(3*i)
+ df[i,2] <- df[i-1,2]+((0.98)^i)*sin(3*i)
aRt
ref: https://fronkonstin.com/2017/12/23/tiny-art-in-less-than-280-characters/
aRt
> t=seq(1, 80, by=.001)
> plot(exp(-0.005*t)*sin(t*3.019+2.677)+
+ exp(-0.001*t)*sin(t*2.959+2.719),
+ exp(-0.005*t)*sin(t*2.964+0.229)+
+ exp(-0.008*t)*sin(t*2.984+1.284),
+ type="l", axes=FALSE," , ylab="")
ggpubr
ggdonutchart
ggsci
theme(plot.background = element_rect(fill = "palegoldenrod"))
ggiraph
ref:r-graph-gallery.com
ggplot2 ggthemes pack.
> ggplot(dt.long,aes(factor(variable), value))+
+ geom_violin(aes(fill=factor(variable)))+
+ geom_boxplot(alpha=0.2, color="purple", width=.2)+
+ labs(x = "", y = "")+
+ theme_bw()+
+ theme(legend.title = element_blank())+
+ facet_wrap(~variable, scales="free")
ref: aledemogr.com
ggplot2
ggplot(diamonds, aes(cut)) +
+ geom_bar(aes(fill = clarity), position = "dodge") +
+ scale_fill_brewer(palette="PuOr") +
+ geom_hline(yintercept = 2710, color="black") +
+ annotate("text", x = 1.5, y=2250, label = "Threshold value", color= "darkred")
VOLKAN OBAN
Plotrix
Test color legends
Plotrix
clock24.plot
ref:https://cran.r-project.org/web/packages/plotrix/plotrix.pdf
Plotrix
ref:https://cran.r-project.org/web/packages/plotrix/plotrix.pdf
Plotrix
ref:https://cran.r-project.org/web/packages/plotrix/plotrix.pdf
"TSP" - The Travelling Salesman Problem (TSP).
ref:https://github.com/aschinchon/
spatstat
delaunay
aRt with R
iter=5
> points=12 # Number of points
> radius=2.4
> angles=seq(0, 5*pi*(3-1/points), length.out = points)+pi/2
>
> df=data.frame(x=4, y=4)
> for (k in 1:iter)
+ {
+ temp=data.frame()
+ for (i in 1:nrow(df))
+ { data.frame(x=df[i,"x"]+radius^(k-1)*cos(3*angles),
+ y=df[i,"y"]+radius^(k-1)*sin(3*angles)) %>% rbind(temp) -> temp
+
+ }
+ df=temp
+ }
> df %>%
+ select(x,y) %>%
+ deldir(sort=TRUE) %>%
+ .$dirsgs -> data
>
> # Plot regions with geom_segmen
> data %>%
+ ggplot() +
+ geom_segment(aes(x = x1, y = y1, xend = x2, yend = y2), color="black") +
+ scale_x_continuous(expand=c(0,0))+
+ scale_y_continuous(expand=c(0,0))+
+ coord_fixed() +
+ theme(legend.position = "none",
+ panel.background = element_rect(fill="white"),
+ panel.border = element_rect(colour = "black", fill=NA),
+ axis.ticks = element_blank(),
+ panel.grid = element_blank(),
+ axis.title = element_blank(),
+ axis.text = element_blank())->plot
>
> plot
spatstat
delaunay
spatstat
dirichlet
mosaic
data:happy
ggmosaic package
NHANES
ggplot(data = NHANES) +
+ geom_mosaic(aes(weight = Weight, x = product(Age), fill=factor(SleepHrsNight)), na.rm=TRUE) + theme(axis.text.x=element_text(angle=0, hjust= .5))+labs(x="Age", y=" ggmosaic") + guides(fill=guide_legend(title = "SleepHrsNight", reverse = TRUE))
Plot
> library(ggplot2)
> library(dplyr)
> library(deldir)
>
> iter=4 # Number of iterations (depth)
> points=4# Number of points
> radius=2.4
> angles=seq(0, 4*pi*(5-1/points), length.out = points)+pi/2
>
> # Initial center
> df=data.frame(x=4, y=4)
> for (k in 1:iter)
+ {
+ temp=data.frame()
+ for (i in 1:nrow(df))
+ {
+ data.frame(x=df[i,"x"]+radius^(2*k-2)*cos(5*angles),
+ y=2*df[i,"y"]+radius^(2*k-2)*sin(angles)) %>% rbind(temp) -> temp
+ }
+ df=temp
+ }
> df %>%
+ select(x,y) %>%
+ deldir(sort=TRUE) %>%
+ .$dirsgs -> data
>
> data %>%
+ ggplot() ++
+ geom_segment(aes(x = x1, y = y1, xend = x2, yend = y2), color="darkblue") +
+ scale_x_continuous(expand=c(0,0))+
+ scale_y_continuous(expand=c(0,0))+
+ coord_fixed() +
+ theme(legend.position = "none",
+ panel.background = element_rect(fill="magenta"),
+ panel.border = element_rect(colour = "black", fill=NA),
+ axis.ticks = element_blank(),
+ panel.grid = element_blank(),
+ axis.title = element_blank(),
+ axis.text = element_blank())->plot
>
> plot
fractal-mandelbrot
z <- mandelbrot(iter=15)
> par(pty="s")
> image(z,col=c(topo.colors(n+6),"black"), las=3)
Plot
z <- mandelbrot(iter=400)
> par(pty="s")
> image(z,col=c(topo.colors(n+3),"black"), las=3)
mandelbrot
z <- mandelbrot(iter=100)
> par(pty="s")
> image(z, col=c(topo.colors(n+1),"black"), las=3)
ref:https://github.com/mariodosreis/fractal
fractal
library(fractal)
> z <- mandelbrot(iter=100)
> par(pty="s")
> image(z, col=c(topo.colors(n),"red"), las=1)
art game with R
iter=4
> points=16
> radius=4
> angles=seq(0, 18*pi*(3-1/points), length.out = points)+pi/2
> df=data.frame(x=7, y=7)
> for (k in 1:iter)
+ {
+ temp=data.frame()
+ for (i in 1:nrow(df))
+ {
+ data.frame(x=df[i,"x"]+2*radius^(k-4)*cos(5*angles),
+ y=df[i,"y"]+2*radius^(k-4)*sin(5*angles)) %>% rbind(temp) -> temp
+ }
+ df=temp
+ }
> df %>%
+ select(x,y) %>%
+ deldir(sort=TRUE) %>%
+ .$dirsgs -> data
> data %>%
+ geom_segment(aes(x = x1, y = y1, xend = x2, yend = y2), color="magenta4") +
+ scale_x_continuous(expand=c(0,0))+
+ scale_y_continuous(expand=c(0,0))+
+ coord_fixed() +
+ theme(legend.position = "none",
+ panel.background = element_rect(fill="midnightblue"),
+ panel.border = element_rect(colour = "black", fill=NA),
+ axis.ticks = element_blank(),
+ panel.grid = element_blank(),
+ axis.title = element_blank(),
+ axis.text = element_blank())->plot
>
aRt with R
iter=4
> points=8
> radius=4
> angles=seq(0, 18*pi*(5-1/points), length.out = points)+pi/2
> df=data.frame(x=4, y=4)
> for (k in 1:iter)
+ {
+ temp=data.frame()
+ for (i in 1:nrow(df))
+ {
+ data.frame(x=df[i,"x"]+2*radius^(k-3)*cos(3*angles),
+ y=df[i,"y"]+2*radius^(k-3)*sin(3*angles)) %>% rbind(temp) -> temp
+ }
+ df=temp
+ }
>
art game with R
iter=4
> points=8
> radius=4
>
> angles=seq(0, 18*pi*(5-1/points), length.out = points)+pi/2
> df=data.frame(x=2, y=2)
> for (k in 1:iter)
+ {
+ temp=data.frame()
+ for (i in 1:nrow(df))
+ {
+ data.frame(x=df[i,"x"]+2*radius^(k-3)*cos(2*angles),
+ y=df[i,"y"]+2*radius^(k-3)*sin(2*angles)) %>% rbind(temp) -> temp
+ }
+ df=temp
+ }
aRt with R
iter=4
> points=8
> radius=4
> angles=seq(0, 18*pi*(5-1/points), length.out = points)+pi/2
>
> df=data.frame(x=1, y=1)
igraph and visNetwork
> g <- graph.star(40)
> V(g)$color <- c("red", "white")
>
> E(g)$color <- "black"
> plot(g)
visNetwork
nnodes <- 300
> nnedges <- 1500
> nodes <- data.frame(id = 1:nnodes)
> edges <- data.frame(from = sample(1:nnodes, nnedges, replace = T),
+ to = sample(1:nnodes, nnedges, replace = T))
> # with defaut layout
> visNetwork(nodes,edges) %>%
+ visIgraphLayout()
> # use full space
> visNetwork(nodes, edges") %>%
+ visIgraphLayout(type = "full")
data aRt with R
...............
> iter=5 # Number of iterations (depth)
> points=10 # Number of points
> radius=4 # Factor of expansion/compression
>
> # Angles of points from center
> angles=seq(0, 12*pi*(5-1/points), length.out = points)+pi/2
>
> # Initial center
> df=data.frame(x=0, y=0)
>
> # Iterate over centers again and again
> for (k in 1:iter)
+ {
+ temp=data.frame()
+ for (i in 1:nrow(df))
+ {
+ data.frame(x=df[i,"x"]+6*radius^(k-2)*cos(angles),
+ y=df[i,"y"]+4*radius^(k-2)*sin(2*angles)) %>% rbind(temp) -> temp
+ }
+ df=temp
+ }
>
> # Obtain Voronoi regions
> df %>%
+ select(x,y) %>%
+ deldir(sort=TRUE) %>%
+ .$dirsgs -> data
>
> # Plot regions with geom_segmen
> data %>%
+ ggplot() + ggtitle("by Volkan OBAN using R ") +
+ geom_segment(aes(x = x1, y = y1, xend = x2, yend = y2), color="white") +
+ scale_x_continuous(expand=c(0,0))+
+ scale_y_continuous(expand=c(0,0))+
+ coord_fixed() +
+ theme(legend.position = "none",
+ panel.background = element_rect(fill="black"),
+ panel.border = element_rect(colour = "black", fill=NA),
+ axis.ticks = element_blank(),
+ panel.grid = element_blank(),
+ axis.title = element_blank(),
+ axis.text = element_blank())->plot
................
Plot
............................................
> iter=5
> points=16 # Number of points
> radius=2.5 # Factor of expansion/compression
>
> # Angles of points from center
> angles=seq(0, 2*pi*(8-1/points), length.out = points)+pi/2
>
> # Initial center
> df=data.frame(x=0, y=0)
>
> # Iterate over centers again and again
> for (k in 1:iter)
+ {
+ temp=data.frame()
+ for (i in 1:nrow(df))
+ {
+ data.frame(x=df[i,"x"]+3*radius^(k-1)*cos(angles),
+ y=df[i,"y"]+2*radius^(k-1)*sin(2*angles)) %>% rbind(temp) -> temp
+ }
+ df=temp
+ }
...........................
.........
data aRt with R
data.frame(x=df[i,"x"]+radius^(k-1)*cos(angles^2),
+ y=df[i,"y"]+radius^(k-1)*sin(angles^2)) %>% rbind(temp) -> temp
colors: midnightblue and mediumpurple1
Plot
code:
ref:https://github.com/aschinchon/mandalas
library(dplyr)
> library(deldir)
>
> # Parameters to change as you like
> iter=5 # Number of iterations (depth)
> points=9 # Number of points
> radius=3.9 # Factor of expansion/compression
>
> # Angles of points from center
> angles=seq(0, 3*pi*(4-1/points), length.out = points)+pi/2
>
> # Initial center
> df=data.frame(x=0, y=0)
>
> # Iterate over centers again and again
> for (k in 1:iter)
+ {
+ temp=data.frame()
+ for (i in 1:nrow(df))
+ {
+ data.frame(x=df[i,"x"]+radius^(k-1)*cos(angles),
+ y=df[i,"y"]+radius^(k-1)*sin(angles)) %>% rbind(temp) -> temp
+ }
+ df=temp
+ }
>
> # Obtain Voronoi regions
> df %>%
+ select(x,y) %>%
+ deldir(sort=TRUE) %>%
+ .$dirsgs -> data
>
> # Plot regions with geom_segmen
> data %>%
+ ggplot()
+ geom_segment(aes(x = x1, y = y1, xend = x2, yend = y2), color="white") +
+ scale_x_continuous(expand=c(0,0))+
+ scale_y_continuous(expand=c(0,0))+
+ coord_fixed() +
+ theme(legend.position = "none",
+ panel.background = element_rect(fill="black"),
+ panel.border = element_rect(colour = "white", fill=NA),
+ axis.ticks = element_blank(),
+ panel.grid = element_blank(),
+ axis.title = element_blank(),
+ axis.text = element_blank())->plot
>
> plot
data aRt with R -Mandalas
> iter=4 # Number of iterations (depth)
> points=8 # Number of points
> radius=4 # Factor of expansion/compression
>
> # Angles of points from center
> angles=seq(0, 2*pi*(30-1/points), length.out = points)+pi/2
>
> # Initial center
> df=data.frame(x=0, y=0)
>
> # Iterate over centers again and again
> for (k in 1:iter)
+ {
+ temp=data.frame()
+ for (i in 1:nrow(df))
+ {
+ data.frame(x=df[i,"x"]+radius^(k-1)*cos(angles/4),
+ y=df[i,"y"]+radius^(k-1)*sin(angles/4)) %>% rbind(temp) -> temp
+ }
+ df=temp
+ }
data visulazition in R
> library(ggplot2)
> library(dplyr)
> library(deldir)
>
> # Parameters to change as you like
> iter=4 # Number of iterations (depth)
> points=8 # Number of points
> radius=4 # Factor of expansion/compression
>
> # Angles of points from center
> angles=seq(0, 2*pi*(20-1/points), length.out = points)+pi/2
>
> # Initial center
> df=data.frame(x=0, y=0)
>
> # Iterate over centers again and again
> for (k in 1:iter)
+ {
+ temp=data.frame()
+ for (i in 1:nrow(df))
+ {
+ data.frame(x=df[i,"x"]+radius^(k-1)*cos(angles/2),
+ y=df[i,"y"]+radius^(k-1)*sin(angles/2)) %>% rbind(temp) -> temp
+ }
+ df=temp
+ }
>
> # Obtain Voronoi regions
> df %>%
+ select(x,y) %>%
+ deldir(sort=TRUE) %>%
+ .$dirsgs -> data
>
> # Plot regions with geom_segmen
> data %>%
+ ggplot()
+ geom_segment(aes(x = x1, y = y1, xend = x2, yend = y2), color="purple4") +
+ scale_x_continuous(expand=c(0,0))+
+ scale_y_continuous(expand=c(0,0))+
+ coord_fixed() +
+ theme(legend.position = "none",
+ panel.background = element_rect(fill="plum2"),
+ panel.border = element_rect(colour = "black", fill=NA),
+ axis.ticks = element_blank(),
+ panel.grid = element_blank(),
+ axis.title = element_blank(),
+ axis.text = element_blank())->plot
>
> plot
DATA ART with R
> library(ggplot2)
> library(dplyr)
> library(deldir)
>
> # Parameters to change as you like
> iter=4 # Number of iterations (depth)
> points=8 # Number of points
> radius=4 # Factor of expansion/compression
>
> # Angles of points from center
> angles=seq(0, 2*pi*(20-1/points), length.out = points)+pi/2
>
> # Initial center
> df=data.frame(x=0, y=0)
>
> # Iterate over centers again and again
> for (k in 1:iter)
+ {
+ temp=data.frame()
+ for (i in 1:nrow(df))
+ {
+ data.frame(x=df[i,"x"]+radius^(k-1)*cos(angles)*sin(4*angles),
+ y=df[i,"y"]+radius^(k-1)*sin(angles)*sin(2*angles)) %>% rbind(temp) -> temp
+ }
+ df=temp
+ }
>
> # Obtain Voronoi regions
> df %>%
+ select(x,y) %>%
+ deldir(sort=TRUE) %>%
+ .$dirsgs -> data
>
> # Plot regions with geom_segmen
> data %>%
+ ggplot()
+ geom_segment(aes(x = x1, y = y1, xend = x2, yend = y2), color="black") +
+ scale_x_continuous(expand=c(0,0))+
+ scale_y_continuous(expand=c(0,0))+
+ coord_fixed() +
+ theme(legend.position = "none",
+ panel.background = element_rect(fill="seagreen"),
+ panel.border = element_rect(colour = "black", fill=NA),
+ axis.ticks = element_blank(),
+ panel.grid = element_blank(),
+ axis.title = element_blank(),
+ axis.text = element_blank())->plot
>
> plot
data visulazition in R
> library(ggplot2)
> library(dplyr)
> library(deldir)
>
> # Parameters to change as you like
> iter=4 # Number of iterations (depth)
> points=7 # Number of points
> radius=3.5 # Factor of expansion/compression
>
> # Angles of points from center
> angles=seq(0, 2*pi*(10-1/points), length.out = points)+pi/2
>
> # Initial center
> df=data.frame(x=0, y=0)
>
> # Iterate over centers again and again
> for (k in 1:iter)
+ {
+ temp=data.frame()
+ for (i in 1:nrow(df))
+ {
+ data.frame(x=df[i,"x"]+radius^(k-1)*cos(angles)*sin(4*angles),
+ y=df[i,"y"]+radius^(k-1)*sin(angles)*sin(2*angles)) %>% rbind(temp) -> temp
+ }
+ df=temp
+ }
>
> # Obtain Voronoi regions
> df %>%
+ select(x,y) %>%
+ deldir(sort=TRUE) %>%
+ .$dirsgs -> data
>
> # Plot regions with geom_segmen
> data %>%
+ ggplot() + ggtitle("by Volkan OBAN using R - mandalas") +
+ geom_segment(aes(x = x1, y = y1, xend = x2, yend = y2), color="black") +
+ scale_x_continuous(expand=c(0,0))+
+ scale_y_continuous(expand=c(0,0))+
+ coord_fixed() +
+ theme(legend.position = "none",
+ panel.background = element_rect(fill="plum2"),
+ panel.border = element_rect(colour = "black", fill=NA),
+ axis.ticks = element_blank(),
+ panel.grid = element_blank(),
+ axis.title = element_blank(),
+ axis.text = element_blank())->plot
>
> plot
Plot
> library(ggplot2)
> library(dplyr)
> library(deldir)
> # Parameters to change as you like
> iter=5 # Number of iterations (depth)
> points=7 # Number of points
> radius=4 # Factor of expansion/compression
> # Angles of points from center
> angles=seq(0, 2*pi*(2-1/points), length.out = points)+pi*pi/8
> # Initial center
> df=data.frame(x=0, y=0)
> # Iterate over centers again and again
> for (k in 1:iter)
+ {
+ temp=data.frame()
+ for (i in 1:nrow(df))
+ {
+ data.frame(x=df[i,"x"]+radius^(k-1)*cos(angles)*pi,
+ y=df[i,"y"]+radius^(k-1)*sin(angles)*pi) %>% rbind(temp) -> temp
+ }
+ df=temp
+ }
> # Obtain Voronoi regions
> df %>%
+ select(x,y) %>%
+ deldir(sort=TRUE) %>%
+ .$dirsgs -> data
> # Plot regions with geom_segmen
> data %>%
geom_segment(aes(x = x1, y = y1, xend = x2, yend = y2), color="black") +
+ scale_x_continuous(expand=c(0,0))+
+ scale_y_continuous(expand=c(0,0))+
+ coord_fixed() +
+ theme(legend.position = "none",
+ panel.background = element_rect(fill="red"),
+ panel.border = element_rect(colour = "black", fill=NA),
+ axis.ticks = element_blank(),
+ panel.grid = element_blank(),
+ axis.title = element_blank(),
+ axis.text = element_blank())->plot
> plot
Plot
> library(ggplot2)
> library(dplyr)
> library(deldir)
> # Parameters to change as you like
> iter=5 # Number of iterations (depth)
> points=7 # Number of points
> radius=4 # Factor of expansion/compression
> # Angles of points from center
> angles=seq(0, 2*pi*(4-1/points), length.out = points)+pi/4
> # Initial center
> df=data.frame(x=0, y=0)
> # Iterate over centers again and again
> for (k in 1:iter)
+ {
+ temp=data.frame()
+ for (i in 1:nrow(df))
+ {
+ data.frame(x=df[i,"x"]+radius^(k-1)*cos(angles)*pi*k-2,
+ y=df[i,"y"]+radius^(k-1)*sin(angles)*pi*k) %>% rbind(temp) -> temp
+ }
+ df=temp
+ }
> # Obtain Voronoi regions
> df %>%
+ select(x,y) %>%
+ deldir(sort=TRUE) %>%
+ .$dirsgs -> data
> # Plot regions with geom_segmen
> data %>%
+ geom_segment(aes(x = x1, y = y1, xend = x2, yend = y2), color="black") +
+ scale_x_continuous(expand=c(0,0))+
+ scale_y_continuous(expand=c(0,0))+
+ coord_fixed() +
+ theme(legend.position = "none",
+ panel.background = element_rect(fill="blue"),
+ panel.border = element_rect(colour = "black", fill=NA),
+ axis.ticks = element_blank(),
+ panel.grid = element_blank(),
+ axis.title = element_blank(),
+ axis.text = element_blank())->plot
> plot
data aRt with R -Mandalas
> library(ggplot2)
> library(dplyr)
> library(deldir)
> iter=5 # Number of iterations (depth)
> points=7 # Number of points
> radius=4 # F
> angles=seq(0, 2*pi*(1-1/points), length.out = points)+pi/2
> # Initial center
> df=data.frame(x=0, y=0)
> for (k in 1:iter)
+ {
+ temp=data.frame()
+ for (i in 1:nrow(df))
+ {
+ data.frame(x=df[i,"x"]+radius^(k-1)*cos(angles)*4*k,
+ y=df[i,"y"]+radius^(k-1)*sin(angles)*2*k) %>% rbind(temp) -> temp
+ }
+ df=temp
+ }
> # Obtain Voronoi regions
> df %>%
+ select(x,y) %>%
+ deldir(sort=TRUE) %>%
+ .$dirsgs -> data
> # Plot regions with geom_segmen
> data %>%
+ geom_segment(aes(x = x1, y = y1, xend = x2, yend = y2), color="black") +
+ scale_x_continuous(expand=c(0,0))+
+ scale_y_continuous(expand=c(0,0))+
+ coord_fixed() +
+ theme(legend.position = "none",
+ panel.background = element_rect(fill="green"),
+ panel.border = element_rect(colour = "black", fill=NA),
+ axis.ticks = element_blank(),
+ panel.grid = element_blank(),
+ axis.title = element_blank(),
+ axis.text = element_blank())->plot
> plot
Plot
data.frame(x=df[i,"x"]+2*pi*radius^(k-1)*cos(angles)*sin(angles) ,
+ y=df[i,"y"]+2*pi*radius^(k-2)*sin(angles))
mandalas
+ for (i in 1:nrow(df))
+ {
+ data.frame(x=df[i,"x"]+2*pi*radius^(k-1)*cos(angles)+ sin(angles) ,
+ y=df[i,"y"]+2*pi*radius^(k-2)*sin(angles)) %>% rbind(temp) -> temp
+ }
+ df=temp
data-aRt
library(ggplot2)
> library(dplyr)
> library(deldir)
>
> iter=5 # Number of iterations (depth)
> points=7 # Number of points
> radius=3.6 # Factor of expansion/compression
>
> # Angles of points from center
> angles=seq(0, 2*pi*(1-1/points), length.out = points)+pi/2
> df=data.frame(x=0, y=0)
> for (k in 1:iter)
+ {
+ temp=data.frame()
+ for (i in 1:nrow(df))
+ {
+ data.frame(x=df[i,"x"]+4*pi*radius^(k-3)*cos(angles)+ sin(angles) ,
+ y=df[i,"y"]+2*pi*radius^(k-2)*sin(angles)) %>% rbind(temp) -> temp
+ }
+ df=temp
+ }
> df %>%
+ select(x,y) %>%
+ deldir(sort=TRUE) %>%
+ .$dirsgs -> data
> data %>%
+ ggplot() +
+ geom_segment(aes(x = x1, y = y1, xend = x2, yend = y2), color="black") +
+ scale_x_continuous(expand=c(0,0))+
+ scale_y_continuous(expand=c(0,0))+
+ coord_fixed() +
+ theme(legend.position = "none",
+ panel.background = element_rect(fill="firebrick1"),
+ panel.border = element_rect(colour = "black", fill=NA),
+ axis.ticks = element_blank(),
+ panel.grid = element_blank(),
+ axis.title = element_blank(),
+ axis.text = element_blank())->plot
>
> plot
Plot
> library(ggplot2)
> library(dplyr)
> library(deldir)
>
> iter=3 # Number of iterations (depth)
> points=6 # Number of points
> radius=3.8 # Factor of expansion/compression
>
> angles=seq(0, 2*pi*(1-1/points), length.out = points)+pi/2
>
> df=data.frame(x=0, y=0)
> for (k in 1:iter)
+ {
+ temp=data.frame()
+ for (i in 1:nrow(df))
+ {
+ data.frame(x=df[i,"x"]+4*pi*radius^(k-3)*cos(angles)+ sin(angles) ,
+ y=df[i,"y"]+2*pi*radius^(k-2)*sin(angles)) %>% rbind(temp) -> temp
+ }
+ df=temp
+ }
>
s
> df %>%
+ select(x,y) %>%
+ deldir(sort=TRUE) %>%
+ .$dirsgs -> data
>
> data %>%
+ ggplot() + ggtitle((" Mandalas")) +
+ geom_segment(aes(x = x1, y = y1, xend = x2, yend = y2), color="black") +
+ scale_x_continuous(expand=c(0,0))+
+ scale_y_continuous(expand=c(0,0))+
+ coord_fixed() +
+ theme(legend.position = "none",
+ panel.background = element_rect(fill="seagreen3"),
+ panel.border = element_rect(colour = "black", fill=NA),
+ axis.ticks = element_blank(),
+ panel.grid = element_blank(),
+ axis.title = element_blank(),
+ axis.text = element_blank())->plot
>
> plot
ref:https://github.com/aschinchon/mandalas/blob/master/mandala.R
mandalas
..... data.frame(x=df[i,"x"]+4*pi*radius^(k-1)*cos(angles) + sin(angles) ,
+ y=df[i,"y"]+2*pi*radius^(k-1)*sin(angles)) %>% rbind(temp) -> temp..............
mandalas
> library(ggplot2)
> library(dplyr)
> library(deldir)
>
> # Parameters to change as you like
> iter=3 # Number of iterations (depth)
> points=6 # Number of points
> radius=3.8 # Factor of expansion/compression
>
> # Angles of points from center
> angles=seq(0, 2*pi*(1-1/points), length.out = points)+pi/2
>
> # Initial center
> df=data.frame(x=0, y=0)
>
> # Iterate over centers again and again
> for (k in 1:iter)
+ {
+ temp=data.frame()
+ for (i in 1:nrow(df))
+ {
+ data.frame(x=df[i,"x"]+4*radius^(k-1)*cos(angles),
+ y=df[i,"y"]+2*radius^(k-1)*sin(angles)) %>% rbind(temp) -> temp
+ }
+ df=temp
+ }
>
> # Obtain Voronoi regions
> df %>%
+ select(x,y) %>%
+ deldir(sort=TRUE) %>%
+ .$dirsgs -> data
>
> # Plot regions with geom_segmen
> data %>%
+ ggplot() + ggtitle((" Mandalas")) +
+ geom_segment(aes(x = x1, y = y1, xend = x2, yend = y2), color="black") +
+ scale_x_continuous(expand=c(0,0))+
+ scale_y_continuous(expand=c(0,0))+
+ coord_fixed() +
+ theme(legend.position = "none",
+ panel.background = element_rect(fill="violetred4"),
+ panel.border = element_rect(colour = "black", fill=NA),
+ axis.ticks = element_blank(),
+ panel.grid = element_blank(),
+ axis.title = element_blank(),
+ axis.text = element_blank())->plot
>
> plot
mandalas
> library(ggplot2)
> library(dplyr)
> library(deldir)
>
> # Parameters to change as you like
> iter=3 # Number of iterations (depth)
> points=6 # Number of points
> radius=3.8 # Factor of expansion/compression
>
> # Angles of points from center
> angles=seq(0, 2*pi*(1-1/points), length.out = points)+pi/2
>
> # Initial center
> df=data.frame(x=0, y=0)
>
> # Iterate over centers again and again
> for (k in 1:iter)
+ {
+ temp=data.frame()
+ for (i in 1:nrow(df))
+ {
+ data.frame(x=df[i,"x"]+radius^(k-1)*cos(angles),
+ y=df[i,"y"]+2*radius^(k-1)*sin(angles)) %>% rbind(temp) -> temp
+ }
+ df=temp
+ }
>
> # Obtain Voronoi regions
> df %>%
+ select(x,y) %>%
+ deldir(sort=TRUE) %>%
+ .$dirsgs -> data
>
> # Plot regions with geom_segmen
> data %>%
+ ggplot() + ggtitle((" by Volkan OBAN using R - Mandalas")) +
+ geom_segment(aes(x = x1, y = y1, xend = x2, yend = y2), color="black") +
+ scale_x_continuous(expand=c(0,0))+
+ scale_y_continuous(expand=c(0,0))+
+ coord_fixed() +
+ theme(legend.position = "none",
+ panel.background = element_rect(fill="royalblue1"),
+ panel.border = element_rect(colour = "black", fill=NA),
+ axis.ticks = element_blank(),
+ panel.grid = element_blank(),
+ axis.title = element_blank(),
+ axis.text = element_blank())->plot
>
> plot
mandalas
library(ggplot2)
library(dplyr)
library(deldir)
# Parameters to change as you like
iter=5 # Number of iterations (depth)
points=7 # Number of points
radius=3.8 # Factor of expansion/compression
# Angles of points from center
angles=seq(0, 2*pi*(1-1/points), length.out = points)+pi/2
# Initial center
df=data.frame(x=0, y=0)
# Iterate over centers again and again
for (k in 1:iter)
{
temp=data.frame()
for (i in 1:nrow(df))
{
data.frame(x=df[i,"x"]+radius^(k-1)*sin(angles)*cos(angles),
y=df[i,"y"]+radius^(k-1)*sin(angles)) %>% rbind(temp) -> temp
}
df=temp
}
# Obtain Voronoi regions
df %>%
select(x,y) %>%
deldir(sort=TRUE) %>%
.$dirsgs -> data
# Plot regions with geom_segmen
data %>%
ggplot() + ggtitle("Mandalas") +
geom_segment(aes(x = x1, y = y1, xend = x2, yend = y2), color="black") +
scale_x_continuous(expand=c(0,0))+
scale_y_continuous(expand=c(0,0))+
coord_fixed() +
theme(legend.position = "none",
panel.background = element_rect(fill="lightsteelblue"),
panel.border = element_rect(colour = "black", fill=NA),
axis.ticks = element_blank(),
panel.grid = element_blank(),
axis.title = element_blank(),
axis.text = element_blank())->plot
plot
ggplot2 and ggthemr
> ggthemr('chalk')
> library(ggthemes)
> g <- ggplot(mpg, aes(class, cty))
> g + geom_boxplot(aes(fill=factor(cyl))) +
+ theme(axis.text.x = element_text(angle=65, vjust=0.6)) +
+ labs(title=" - ggtherm and ggplot2",
+ subtitle="City Mileage grouped by Class of vehicle",
+ caption="Source: mpg",
+ x="Class of Vehicle",
+ y="City Mileage")
ggplot2 and ggthemr
ggthemr('earth')
> library(ggthemes)
> g <- ggplot(mpg, aes(class, cty))
> g + geom_boxplot(aes(fill=factor(cyl))) +
+ theme(axis.text.x = element_text(angle=65, vjust=0.6)) +
+ labs(title=" ggtherm and ggplot2",
+ subtitle="City Mileage grouped by Class of vehicle",
+ caption="Source: mpg",
+ x="Class of Vehicle",
+ y="City Mileage")
ggthemr
ggthemr('grass')
> library(ggthemes)
> g <- ggplot(mpg, aes(class, cty))
> g + geom_boxplot(aes(fill=factor(cyl))) +
+ theme(axis.text.x = element_text(angle=65, vjust=0.6)) +
+ labs(title=" ggtherm and ggplot2",
+ subtitle="City Mileage grouped by Class of vehicle",
+ caption="Source: mpg",
+ x="Class of Vehicle",
+ y="City Mileage")
Plot
library(ggthemes)
ggthemr('sea)
> g <- ggplot(mpg, aes(class, cty))
> g + geom_boxplot(aes(fill=factor(cyl))) +
+ theme(axis.text.x = element_text(angle=65, vjust=0.6)) +
+ labs(title="ggtherm and ggplot2",
+ subtitle="City Mileage grouped by Class of vehicle",
+ caption="Source: mpg",
+ x="Class of Vehicle",
+ y="City Mileage")
hexbin
> x <- rnorm(10000)
> y <- rnorm(10000)
> bin <- hexbin(x,y)
> ## Plot method for hexbin !
> ## ---- ------ --------
> plot(bin)
> # nested lattice
> plot(bin,, style= "nested.lattice")
hexbin
> set.seed(153)
> x <- rnorm(100000)
> y <- rnorm(100000)
> bin <- hexbin(x,y)
> smbin <- smooth.hexbin(bin)
> erodebin <- erode.hexbin(smbin, cdfcut=.4)
> plot(erodebin,main = "")
yarrr
Show in New WindowClear OutputExpand/Collapse Output
shiny.tag
shiny.tag
shiny.tag
shiny.tag
shiny.tag
shiny.tag
shiny.tag
shiny.tag
Show in New WindowClear OutputExpand/Collapse Output
Error: unexpected symbol in:
"
print(p)Show"
Modify Chunk OptionsRun All Chunks AboveRun Current ChunkModify Chunk OptionsRun All Chunks AboveRun Current ChunkModify Chunk OptionsRun All Chunks AboveRun Current Chunk
Console~/
> pirateplot(formula = budget ~ creative.type,
+ data = subset(movies, budget > 0 &
+ creative.type %in% c("Multiple Creative Types", "Factual") == FALSE),
+ point.o = .02,
+ xlab = "",
+ main = " Data visualization with R - yarrr ",
+ gl.col = "gray",
+ pal = "black")
>
> mtext("Movie budgets (in millions) by rating -- pirateplot",
+ side = 3,
+ font = 3)
>
> mtext("*movies tend to have the highest budgets\n...by far!",
+ side = 1, adj = 1, line = 3,
+ cex = .8, font = 3)
yarrr
pirateplot(formula = weight ~ Time,
data = ChickWeight,
main = "Weights of chickens by Time",
pal = "xmen",
gl.col = "gray")
mtext(text = "Using the xmen palette!",
side = 3,
font = 3)
mtext(text = "*The mean and variance of chicken\nweights tend to increase over time.",
side = 1,
adj = 1,
line = 3.5,
font = 3,
cex = .7)
swatches
ref: https://www.r-bloggers.com/new-package-swatches-is-now-on-cran/
library(swatches)
library(hrbrthemes)
library(tidyverse)
download.file("https://www.pantone.com/images/pages/21348/adobe-ase/Pantone-COY18-Palette-ASE-files.zip", "ultra_violet.zip")
unique(dirname((unzip("ultra_violet.zip"))))
## [1] "./Pantone COY18 Palette ASE files"
## [2] "./__MACOSX/Pantone COY18 Palette ASE files"
dir("./Pantone COY18 Palette ASE files")
par(mfrow=c(8,1))
dir("./Pantone COY18 Palette ASE files", full.names=TRUE) %>%
walk(~{
pal_name <- gsub("(^[[:alnum:]]+-|\\.ase$)", "", basename(.x))
show_palette(read_palette(.x))
title(pal_name)
})
par(mfrow=c(1,1))
(intrigue <- read_palette("./Pantone COY18 Palette ASE files/PantoneCOY18-Intrigue.ase"))
(intrigue <- read_palette("./Pantone COY18 Palette ASE files/PantoneCOY18-Intrigue.ase", use_names=FALSE))
ggplot(economics_long, aes(date, value)) +
geom_area(aes(fill=variable)) +
scale_y_comma() +
scale_fill_manual(values=intrigue) +
facet_wrap(~variable, scales = "free", nrow = 2, strip.position = "bottom") +
theme_ipsum_rc(grid="XY", strip_text_face="bold") +
theme(strip.placement = "outside") +
theme(legend.position=c(0.85, 0.2))
PDN-Personalized Disease Network
#Select a subset of data for toy example
comorbidity_data = comorbidity_data[c(1:10),]
survival_data = survival_data[c(1:10),]
# Find date cuts
k1 = datecut(comorbidity_data,survival_data[,1],survival_data[,2])
# Build networks
a = buildnetworks(comorbidity_data,k1)
# Graph individual patients
datark = t(apply(comorbidity_data,1,rank))
dak = sort(datark[1,])
# draw PDN for the first patient
draw.PDN.circle(a[1,],dak)
# draw PDN for the whole comorbidity data set
par(mfrow=c(2,5))
for(i in 1 : nrow(a)){
dak = apply(datark,2,sort)
draw.PDN.circle(a[i,],dak[i,])
title(main=paste("Patient",i))
}
Plot
library(ggplot2)
library(ggthemes)
> theme_set(theme_bw())
> g <- ggplot(mpg, aes(manufacturer, cty))
> g + geom_boxplot() +
+ geom_dotplot(binaxis='y',
+ stackdir='center',
+ dotsize = .5,
+ fill="yellow") +
+ theme(axis.text.x = element_text(angle=65, vjust=0.6)) +
+ labs(title=" ",
+ caption="Data visualization with R",
+ x="Class of Vehicle",
+ y="City Mileage") +theme_hc(bgcolor = "darkunica") +
+ scale_fill_hc("darkunica"
sunflowerplot
sunflowerplot(rnorm(1000), rnorm(1000), number = rpois(n = 1000, lambda = 2),rotate = TRUE, col = "purple")
animation
> library(ggplot2)
> library(dplyr)
> library(tidyr)
> library(purrr)
> library(animation)
> library(gganimate)
>
> ## Function to evaluate Beta pdf for a vector of values ##
> calc_beta = function(alpha, beta){
+ x = seq(0.01, 0.99, 0.01)
+ densityf = dbeta(x, shape = alpha, shape2 = beta)
+ return(data_frame(x, densityf))
+ }
>
> ## Create data frame with evaluation of Beta pdf for different combinations of alpha and beta ##
> alpha = c(0.1, 0.5, 1:5, 10)
> beta = c(0.5, 1, 2, 5)
>
> ## Create data frame ##
> # Couldn't get the pipe operator to properly show up in WordPress :-(
> df = expand.grid(alpha = alpha, beta = beta)
> df = group_by(df, alpha, beta)
> df = unnest(mutate(df, plotdata = map2(alpha, beta, calc_beta)))
>
> ## Create plot ##
> p = ggplot(df, aes(x = x, y = densityf, colour = factor(alpha), group = factor(alpha))) + ggtitle("by Volkan OBAN using R ")+
+ geom_path(aes(frame = alpha, cumulative = TRUE), size = 0.5) +
+ facet_wrap(~beta,
+ labeller = label_bquote(cols = beta == .(beta))) +
+ ylim(c(0, 6)) +
+ labs(y = expression(paste("f(x; ", alpha, ", ", beta, ")")),
+ title = "Changing parameters in Beta density function") +
+ scale_colour_discrete(name = expression(alpha)) +
+ theme(plot.title = element_text(hjust = 0.5))
Warning: Ignoring unknown aesthetics: frame, cumulative
>
> ani.options(interval = 0.8)
> gganimate(p, title_frame = FALSE, width = 4, height = 4)
reference: http://www.masterdataanalysis.com/r/creating-animations-ggplot2-plots/
tweenr
> library(ggplot2)
> library(gganimate)
> library(ggforce)
> library(tweenr)
>
> # Making up data
> d <- data.frame(x = rnorm(20), y = rnorm(20), time = sample(100, 20), alpha = 0,
+ size = 1, ease = 'elastic-out', id = 1:20,
+ stringsAsFactors = FALSE)
> d2 <- d
> d2$time <- d$time + 10
> d2$alpha <- 1
> d2$size <- 3
> d2$ease <- 'linear'
> d3 <- d2
> d3$time <- d2$time + sample(50:100, 20)
> d3$size = 10
> d3$ease <- 'bounce-out'
> d4 <- d3
> d4$y <- min(d$y) - 0.5
> d4$size <- 2
> d4$time <- d3$time + 10
> d5 <- d4
> d5$time <- max(d5$time)
> df <- rbind(d, d2, d3, d4, d5)
>
> # Using tweenr
> dt <- tween_elements(df, 'time', 'id', 'ease', nframes = 500)
>
> # Animate with gganimate
> p <- ggplot(data = dt) +
+ geom_point(aes(x=x, y=y, size=size, alpha=alpha, frame = .frame)) +
+ scale_size(range = c(0.1, 20), guide = 'none') +
+ scale_alpha(range = c(0, 1), guide = 'none') +
+ ggforce::theme_no_axes()
Warning: Ignoring unknown aesthetics: frame
> animation::ani.options(interval = 1/24)
> gganimate(p, 'dropping balls.gif', title_frame = F)
tweenr
library(ggplot2)
> library(gganimate)
> library(ggforce)
> library(tweenr)
>
> # Making up data
> t <- data.frame(x=0, y=0, colour = 'forestgreen', size=1, alpha = 1,
+ stringsAsFactors = FALSE)
> t <- t[rep(1, 12),]
> t$alpha[2:12] <- 0
> t2 <- t
> t2$y <- 1
> t2$colour <- 'firebrick'
> t3 <- t2
> t3$x <- 1
> t3$colour <- 'steelblue'
> t4 <- t3
> t4$y <- 0
> t4$colour <- 'goldenrod'
> t5 <- t4
> c <- ggforce::radial_trans(c(1,1), c(1, 12))$transform(rep(1, 12), 1:12)
> t5$x <- (c$x + 1) / 2
> t5$y <- (c$y + 1) / 2
> t5$alpha <- 1
> t5$size <- 0.5
> t6 <- t5
> t6 <- rbind(t5[12,], t5[1:11, ])
> t6$colour <- 'firebrick'
> t7 <- rbind(t6[12,], t6[1:11, ])
> t7$colour <- 'steelblue'
> t8 <- t7
> t8$x <- 0.5
> t8$y <- 0.5
> t8$size <- 2
> t9 <- t
> ts <- list(t, t2, t3, t4, t5, t6, t7, t8, t9)
>
> tweenlogo <- data.frame(x=0.5, y=0.5, label = 'tweenr', stringsAsFactors = F)
> tweenlogo <- tweenlogo[rep(1, 60),]
> tweenlogo$.frame <- 316:375
>
> # Using tweenr
> tf <- tween_states(ts, tweenlength = 2, statelength = 1,
+ ease = c('cubic-in-out', 'elastic-out', 'bounce-out',
+ 'cubic-out', 'sine-in-out', 'sine-in-out',
+ 'circular-in', 'back-out'),
+ nframes = 375)
>
> # Animate with gganimate
> p <- ggplot(data=tf, aes(x=x, y=y)) +
+ geom_text(aes(label = label, frame = .frame), data=tweenlogo, size = 13) +
+ geom_point(aes(frame = .frame, size=size, alpha = alpha, colour = colour)) +
+ scale_colour_identity() +
+ scale_alpha(range = c(0, 1), guide = 'none') +
+ scale_size(range = c(4, 60), guide = 'none') +
+ expand_limits(x=c(-0.36, 1.36), y=c(-0.36, 1.36)) +
+ theme_bw()
Warning: Ignoring unknown aesthetics: frame
Warning: Ignoring unknown aesthetics: frame
> animation::ani.options(interval = 1/15)
> gganimate(p, "dancing ball.gif", title_frame = F, ani.width = 400,
+ ani.height = 400)
D3partitionR
d3 = D3partitionR() %>%
add_data(data_plot,count = 'N',tooltip=c('name','Location'),steps=c('Sex','Embarked','Pclass','Survived')) %>%
add_nodes_data(list('Embarked S'=list('Location'='<a href="https://fr.wikipedia.org/wiki/Southampton">Southampton</a>'),
'Embarked C'=list('Location'='<a href="https://fr.wikipedia.org/wiki/Cherbourg-Octeville">Cherbourg</a>'),
'Embarked Q'=list('Location'='<a href="https://fr.wikipedia.org/wiki/Cobh">Queenstown</a>')
)
)
d3 %>%
set_legend_parameters(zoom_subset = TRUE) %>%
set_chart_type('circle_treemap') %>%
set_tooltip_parameters(visible=TRUE, style='background-color:lightblue;',builder='basic') %>%
plot()
plotly
library(ggplot2)
> data.diamonds=ggplot2::diamonds
> library(plotly)
> gg=ggplot(data.diamonds,aes(x=carat,y=price,color=color))+geom_point(alpha=0.3)
> ggplotly(gg)
ggiraph
dataset = data.frame( x1 = c(1, 5, 1, 3, 0),
+ x2 = c(2, 4, 0, 4, 5),
+ y1 = c( 1, 8, 0, 1, 3),
+ y2 = c( 2, 2, 5, 3, 4),
+ t = c( 'O', 'O', 'O', 'V', 'V'),
+ r = c( 1, 2, 3, 4, 5),
+ tooltip = c("ID 1", "ID 2", "ID 3", "ID 4", "ID 5"),
+ uid = c("ID 1", "ID 2", "ID 3", "ID 4", "ID 5"),
+ oc = rep("alert(this.getAttribute(\"data-id\"))", 5)
+ )
>
> gg_rect = ggplot() +
+ scale_x_continuous(name="x ") +
+ scale_y_continuous(name="y") +
+ geom_rect_interactive(data=dataset,
+ mapping = aes(xmin = x1, xmax = x2,
+ ymin = y1, ymax = y2, fill = t,
+ tooltip = tooltip, onclick = oc, data_id = uid ),
+ color="purple", alpha=0.6) +
+ geom_text(data=dataset,
+ aes(x = x1 + ( x2 - x1 ) / 2, y = y1 + ( y2 - y1 ) / 2,
+ label = r ),
+ size = 4 )
>
>
> ggiraph(code = {print(gg_rect)})
ggiraph
p <- ggplot(mpg, aes(x = drv, y = hwy, tooltip = class, fill = class)) +
+ geom_boxplot_interactive(outlier.colour = "blue") +
guides(fill = "none") + theme_minimal()
> ggiraph(code = print(p))
heatmap
ggplot(train, aes(Outlet_Identifier, Item_Type))+
+ geom_raster(aes(fill = Item_MRP))+
+ labs(title =" Heat Map", x = "Outlet Identifier", y = "Item Type")+
+ scale_fill_continuous(name = "Item MRP")
ggplot2
> ggplot(train, aes(Outlet_Identifier, Item_Outlet_Sales)) + geom_boxplot(fill = "yellow")+
+ scale_y_continuous("Item Outlet Sales", breaks= seq(0,15000, by=500))+
+ labs(title = "", x = "Outlet Identifier")
data<-https://docs.google.com/spreadsheets/d/1PR5StHxg2jlMCb4IUilGSEwhylXn-3q3EJucSaVolCU/edit#gid=0
ggplot2 and ggthemes
> yearly_weight <- surveys_complete %>%
+ group_by(year, species_id, sex) %>%
+ summarise(avg_weight = mean(weight, na.rm = TRUE))
> ggplot(yearly_weight, aes(x=year, y=avg_weight, color = sex, group = sex)) +
+ geom_line() +
+ facet_wrap(~ species_id) + theme_solarized() +
+ scale_colour_solarized("blue")
ggplot2 and ggthemes
> ggplot(surveys_complete, aes(x = species_id, y = hindfoot_length)) +
+ geom_boxplot(alpha = 0) +
+ geom_jitter(alpha = 0.3, color = "yellow")+ theme_solarized_2(light = FALSE) +
+ scale_colour_solarized("blue")
Plot3d
ref
https://cran.r-project.org/web/packages/plot3D/vignettes/plot3D.pdf
Plot3d
ref: https://cran.r-project.org/web/packages/plot3D/vignettes/plot3D.pdf
plot3D
> x <- (3 + cos(2*v)*sin(2*u) - sin(3*v)*sin(2*u))*cos(v)
> y <- (3 + cos(v)*sin(u) - sin(v)*sin(3*u))*sin(v);z <- sin(v)*sin(2*u) + cos(v)*sin(u)
> surf3D(x, y, z,,colvar = z, colkey = FALSE, facets = FALSE)
plot3D
> x <- (3 + cos(v/2)*sin(u) - sin(v/2)*sin(2*u))*cos(v)
> y <- (3 + cos(v/2)*sin(u) - sin(v/2)*sin(2*u))*sin(v)
> z <- sin(2*v)*sin(u) + cos(2*v)*sin(2*u)
> surf3D(x, y, z, colvar = z, colkey = FALSE, facets = FALSE)
plot3D
> M <- mesh(seq(0, 6*pi, length.out = 80), seq(pi/3, pi, length.out = 80))
> u <- M$x ; v <- M$y
> x <- u/2 * cos(2*v)
> y <- u/2 * sin(v) * sin(2*u)
> z <- u/2 * sin(2*v)
> surf3D(x, y, z, colvar = z,colkey = FALSE, box = FALSE)
ggplot2
library(tidyverse)
library(viridis)
library(OECD)
# search by keyword
search_dataset("unemployment") %>% View
# download the selected dataset
df_oecd <- get_dataset("AVD_DUR")
# turn variable names to lowercase
names(df_oecd) <- names(df_oecd) %>% tolower()
df_oecd %>%
filter(country %in% c("EU16", "EU28", "USA"), sex == "MEN", ! age == "1524") %>%
ggplot(aes(obstime, age, fill = obsvalue))+
geom_tile()+
scale_fill_viridis("Months", option = "B")+
scale_x_discrete(breaks = seq(1970, 2015, 5) %>% paste)+
facet_wrap(~ country, ncol = 1)+
labs(x = NULL, y = "Age groups",
title = "Average duration of unemployment in months, males")+
theme_minimal()
Clifford Attractors
> library("compiler")
>
> mapxy <- function(x, y, xmin, xmax, ymin=xmin, ymax=xmax) {
+ sx <- (width - 1) / (xmax - xmin)
+ sy <- (height - 1) / (ymax - ymin)
+ row0 <- round( sx * (x - xmin) )
+ col0 <- round( sy * (y - ymin) )
+ col0 * height + row0 + 1
+ }
>
> dejong <- function(x, y) {
+ nidxs <- length(mat)
+ counts <- integer(length=nidxs)
+ for (i in 1:npoints) {
+ xt <- sin(a * y) - cos(b * x)
+ y <- sin(c * x) - cos(d * y)
+ x <- xt
+ idxs <- mapxy(x, y, -2, 2)
+ counts <- counts + tabulate(idxs, nbins=nidxs)
+ }
+ mat <<- mat + counts
+ }
>
> clifford <- function(x, y) {
+ ac <- abs(c)+1
+ ad <- abs(d)+1
+ nidxs <- length(mat)
+ counts <- integer(length=nidxs)
+ for (i in 1:npoints) {
+ xt <- sin(a * y) + c * cos(a * x)
+ y <- sin(b * x) + d * cos(b * y)
+ x <- xt
+ idxs <- mapxy(x, y, -ac, ac, -ad, ad)
+ counts <- counts + tabulate(idxs, nbins=nidxs)
+ }
+ mat <<- mat + counts
+ }
>
> #color vector
> cvec <- grey(seq(0, 1, length=10))
> #can also try other colours, see help(rainbow)
> #cvec <- heat.colors(10)
>
> #we end up with npoints * n points
> npoints <- 8
> n <- 100000
> width <- 600
> height <- 600
>
> #make some random points
> rsamp <- matrix(runif(n * 2, min=-2, max=2), nr=n)
>
> #compile the functions
> setCompilerOptions(suppressAll=TRUE)
> mapxy <- cmpfun(mapxy)
> dejong <- cmpfun(dejong)
> clifford <- cmpfun(clifford)
>
> #dejong
> a <- 1.4
> b <- -2.3
> c <- 2.4
> d <- -2.1
>
> mat <- matrix(0, nr=height, nc=width)
> dejong(rsamp[,1], rsamp[,2])
>
> #this applies some smoothing of low valued points, from A.N. Spiess
> #QUANT <- quantile(mat, 0.5)
> #mat[mat <= QUANT] <- 0
>
> dens <- log(mat + 1)/log(max(mat))
> par(mar=c(0, 0, 0, 0))
> image(t(dens), col=cvec, useRaster=T, xaxt='n', yaxt='n')
>
> #clifford
> a <- -1.4
> b <- 1.6
> c <- 1.0
> d <- 0.7
>
> mat <- matrix(0, nr=height, nc=width)
> #QUANT <- quantile(mat, 0.5)
> #mat[mat <= QUANT] <- 0
> clifford(rsamp[,1], rsamp[,2])
>
> dens <- log(mat + 1)/log(max(mat))
> par(mar=c(0, 0, 0, 0))
> image(t(dens), col=cvec, useRaster=T, xaxt='n', yaxt='n')
Clifford Attractors
library("compiler")
>
> mapxy <- function(x, y, xmin, xmax, ymin=xmin, ymax=xmax) {
+ sx <- (width - 1) / (xmax - xmin)
+ sy <- (height - 1) / (ymax - ymin)
+ row0 <- round( sx * (x - xmin) )
+ col0 <- round( sy * (y - ymin) )
+ col0 * height + row0 + 1
+ }
>
> dejong <- function(x, y) {
+ nidxs <- length(mat)
+ counts <- integer(length=nidxs)
+ for (i in 1:npoints) {
+ xt <- sin(a * y) - cos(b * x)
+ y <- sin(c * x) - cos(d * y)
+ x <- xt
+ idxs <- mapxy(x, y, -2, 2)
+ counts <- counts + tabulate(idxs, nbins=nidxs)
+ }
+ mat <<- mat + counts
+ }
>
> clifford <- function(x, y) {
+ ac <- abs(c)+1
+ ad <- abs(d)+1
+ nidxs <- length(mat)
+ counts <- integer(length=nidxs)
+ for (i in 1:npoints) {
+ xt <- sin(a * y) + c * cos(a * x)
+ y <- sin(b * x) + d * cos(b * y)
+ x <- xt
+ idxs <- mapxy(x, y, -ac, ac, -ad, ad)
+ counts <- counts + tabulate(idxs, nbins=nidxs)
+ }
+ mat <<- mat + counts
+ }
>
> #color vector
> cvec <- grey(seq(0, 1, length=10))
> #can also try other colours, see help(rainbow)
> #cvec <- heat.colors(10)
>
> #we end up with npoints * n points
> npoints <- 8
> n <- 100000
> width <- 600
> height <- 600
>
> #make some random points
> rsamp <- matrix(runif(n * 2, min=-2, max=2), nr=n)
>
> #compile the functions
> setCompilerOptions(suppressAll=TRUE)
> mapxy <- cmpfun(mapxy)
> dejong <- cmpfun(dejong)
> clifford <- cmpfun(clifford)
>
> #dejong
> a <- 1.4
> b <- -2.3
> c <- 2.4
> d <- -2.1
>
> mat <- matrix(0, nr=height, nc=width)
> dejong(rsamp[,1], rsamp[,2])
>
> #this applies some smoothing of low valued points, from A.N. Spiess
> #QUANT <- quantile(mat, 0.5)
> #mat[mat <= QUANT] <- 0
>
> dens <- log(mat + 1)/log(max(mat))
> par(mar=c(0, 0, 0, 0))
> image(t(dens), col=cvec, useRaster=T, xaxt='n', yaxt='n')
>
> #clifford
> a <- -1.4
> b <- 1.6
> c <- 1.0
> d <- 0.7
>
> mat <- matrix(0, nr=height, nc=width)
> #QUANT <- quantile(mat, 0.5)
> #mat[mat <= QUANT] <- 0
> clifford(rsamp[,1], rsamp[,2])
>
> dens <- log(mat + 1)/log(max(mat))
> par(mar=c(0, 0, 0, 0))
> image(t(dens), col=cvec, useRaster=T, xaxt='n', yaxt='n')
ref:https://github.com/petewerner/misc/blob/master/attractor.R
mvmesh
plot( SolidRectangle( a=c(1,3), b=c(2,7),
+ breaks=list( seq(1,3,by=0.25), seq(2,7,by=1) ) ), show.labels=TRUE
RTriangle
> p <- pslg(P=rbind(c(0, 0), c(0, 1), c(0.5, 0.5), c(1, 1), c(1, 0)),
+ S=rbind(c(1, 2), c(2, 3), c(3, 4), c(4, 5), c(5, 1)))
> ## Plot it
> plot(p)
> ## Triangulate it
> tp <- triangulate(p)
>
> ## Triangulate it subject to minimum area constraint
> tp <- triangulate(p, a=0.01)
> plot(tp)
plotmo
if (require(gbm)) {
n <- 100 # toy model for quick demo
x1 <- 3 * runif(n)
x2 <- 3 * runif(n)
x3 <- sample(1:4, n, replace=TRUE)
y <- x1 + x2 + x3 + rnorm(n, 0, .3)
data <- data.frame(y=y, x1=x1, x2=x2, x3=x3)
mod <- gbm(y~., data=data, distribution="gaussian",
n.trees=300, shrinkage=.1, interaction.depth=3,
train.fraction=.8, verbose=FALSE)
plot_gbm(mod)
# plotres(mod) # plot residuals
# plotmo(mod) # plot regression surfaces
}
rpart.plot
tree1 <- rpart(survived~., data=ptitanic)
par(mfrow=c(4,3))
for(iframe in 1:nrow(tree1$frame)) {
cols <- ifelse(1:nrow(tree1$frame) <= iframe, "black", "gray")
prp(tree1, col=cols, branch.col=cols, split.col=cols)
}
rpart.plot
data(ptitanic)
tree <- rpart(age ~ ., data=ptitanic)
rpart.plot(tree, type=4, extra=0, branch.lty=3, box.palette="RdYlGn")
brownian motion
>t <- 0:100 # time
> sig2 <- 0.01
> nsim <- 1000
> ## we'll simulate the steps from a uniform distribution with limits set to
> ## have the same variance (0.01) as before
> X <- matrix(runif(n = nsim * (length(t) - 1), min = -sqrt(3 * sig2), max = sqrt(3 * sig2)), nsim, length(t) - 1)
> X <- cbind(rep(0, nsim), t(apply(X, 1, cumsum)))
> plot(t, X[1, ],xlab = "time", ylab = "y",col="red", ylim = c(-2, 2), type = "l")
> apply(X[2:nsim, ], 1, function(x, t) lines(t, x), t = t)
persp
> x <- seq(-10, 10, length= 30)
> y <- x
> f <- function(x, y) { r <- sqrt(5*x^(-2)+exp(y^2)); 10 * sin(sin(r))/r }
> z <- outer(x, y, f)
> z[is.na(z)] <- 1
> op <- par(bg = "purple")
> persp(x, y, z, theta =70 , phi = 40, expand = 0.5, col = "yellow")
persp
op <- par(bg = "black")
> persp(x, y, z, theta =70 , phi = 40, expand = 0.5, col = "red")
persp-- Perspective Plots
> x <- seq(-10, 10, length= 30)
> y <- x
> f <- function(x, y) { r <- sqrt(5*x^(-2)+exp(y^2)); 10 * sin(sin(r))/r }
> z <- outer(x, y, f)
> z[is.na(z)] <- 1
> op <- par(bg = "gray")
> persp(x, y, z, theta =60 , phi = 30, expand = 0.5, col = "red")
persp-- Perspective Plots
> x <- seq(-10, 10, length= 30)
> y <- x
> f <- function(x, y) { r <- sqrt(x^(-2)+y^2); 10 * sin(cos(r))/r }
> z <- outer(x, y, f)
> z[is.na(z)] <- 1
> op <- par(bg = "white")
persp(x, y, z , theta =60 , phi = 30, expand = 0.5, col = "purple")
persp-- Perspective Plots
x <- seq(-10, 10, length= 30)
y <- x
> f <- function(x, y) { r <- sqrt(x^(-2)+y^2); 10 * sin(cos(r))/r }
> z <- outer(x, y, f)
> z[is.na(z)] <- 1
> op <- par(bg = "white")
> persp(x, y, z, theta = 30, phi = 30, expand = 0.5, col = "red")
lattice - wireframe
> g <- function(x, y) {(1 + y * 2) ^ (-x^2 / y^3) * (1 + y * 1) ^ (x / y)}
>
> require(lattice)
> myRange = seq(0.01, 2, len = 30)
> grid <- expand.grid(x = myRange , y = myRange)
> grid$z <- g(grid$x, grid$y)
> print(wireframe(z ~ x * y",col="purple", grid))
lattice - wireframe
> g <- function(x, y) {(1 + y * 2) ^ (-x / y) * (1 + y * 1) ^ (x / y)}
> require(lattice)
> myRange = seq(0.01, 2, len = 80)
> grid <- expand.grid(x = myRange , y = myRange)
> grid$z <- g(grid$x, grid$y)
> print(wireframe(z ~ x * y,col="purple", grid))
Plot
> a <- 2
> b <- 3
> theta <- seq(0,10*pi,0.01)
> r <- a + b*theta
> data<- data.frame(x=r*cos(theta), y=r*sin(theta)) # Cartesian coords
> library(ggplot2)
> ggplot(data, aes(x,y)) + geom_point(col='green')
Plot
> golden.ratio = (sqrt(5) + 1)/2
> fibonacci.angle=360/(golden.ratio^2)
> c=1
> num_points=630
> x=rep(0,num_points)
> y=rep(0,num_points)
>
> for (n in 1:num_points) {
+ r=c*sqrt(n)
+ theta=fibonacci.angle*(n)
+ x[n]=r*cos(theta)
+ y[n]=r*sin(theta)
+ }
> plot(x,y,axes=FALSE,ann=FALSE,pch=19,cex=1)
ade4
> data (euro123)
> par(mfrow = c(2,2))
> triangle.plot(euro123$in78, clab = 0, cpoi = 2, addmean = TRUE,
+ show = FALSE)
> triangle.plot(euro123$in86, label = row.names(euro123$in78), clab = 0.8)
> triangle.biplot(euro123$in78, euro123$in86)
> triangle.plot(rbind.data.frame(euro123$in78, euro123$in86), clab = 1, addaxes = TRUE, sub = "Principal axis", csub = 2, possub = "topright")
> par(mfrow = c(1,1))
hexbin-hexplom
data(NHANES)
hexplom(NHANES[,9:13], xbins = 20,colramp = BTY, upper.panel = panel.hexboxplot)
lattice - wireframe
> x <- seq(-pi, pi, len = 20)
> y <- seq(-pi, pi, len = 20)
> g <- expand.grid(x = x, y = y)
> g$z <- cos(sqrt(g$x^2 + g$y^2))
> wireframe(z ~ x * y, g, drape = TRUE,
+ aspect = c(3,1), colorkey = TRUE
Plot persp
> x <- y <- seq(-5, 5, length= 20)
> f <- function(x,y){ z <- x^4 + y^3 -3 }
> z <- outer(x,y,f)
> persp(x, y, z,theta = 60, phi = 45, expand = 0.5, col = "purple")
>
Plot
> x <- y <- seq(-5, 5, length= 20)
> f <- function(x,y){ z <- x*2 + y^3 -3 }
> z <- outer(x,y,f)
> persp(x, y, z,theta = 60, phi = 45, expand = 0.5, col = "red")
Plot- persp
> x <- y <- seq(-5, 5, length= 20)
> f <- function(x,y){ z <- x*2 + y -3 }
> z <- outer(x,y,f)
> persp(x, y, z, theta = 30, phi = 30, expand = 0.5, col = "red")
deSolve package
time <- seq(0, 50, by = 0.01)
# parameters: a named vector
parameters <- c(r = 2, k = 0.5, e = 0.1, d = 1)
# initial condition: a named vector
state <- c(V = 1, P = 3)
# R function to calculate the value of the derivatives at each time value
# Use the names of the variables as defined in the vectors above
lotkaVolterra <- function(t, state, parameters){
with(as.list(c(state, parameters)), {
dV = r * V - k * V * P
dP = e * k * V * P - d * P
return(list(c(dV, dP)))
})
}
## Integration with 'ode'
out <- ode(y = state, times = time, func = lotkaVolterra, parms = parameters)
## Ploting
out.df = as.data.frame(out) # required by ggplot: data object must be a data frame
library(reshape2)
out.m = melt(out.df, id.vars='time') # this makes plotting easier by puting all variables in a single column
p <- ggplot(out.m, aes(time, value, color = variable)) + geom_point()
p
igraph
g <‐ make_lattice(dimvector = c(5,5),
+ circular = FALSE)
plot(g,vertex.color=c("red", "darkslateblue","gold","lightblue","pink"))
igraph
> g<- make_tree(60, children=3)
> plot(g,vertex.color=c("red", "darkslateblue","gold","lightblue","pink"))
Sales Funnel with R . by means of https://www.r-bloggers.com/
library(dplyr)
library(ggplot2)
library(reshape2)
# creating a data samples
# content
df.content <- data.frame(content = c('main', 'ad landing',
'product 1', 'product 2', 'product 3', 'product 4',
'shopping cart',
'thank you page'),
step = c('awareness', 'awareness',
'interest', 'interest', 'interest', 'interest',
'desire',
'action'),
number = c(150000, 80000,
80000, 40000, 35000, 25000,
130000,
120000))
# customers
df.customers <- data.frame(content = c('new', 'engaged', 'loyal'),
step = c('new', 'engaged', 'loyal'),
number = c(25000, 40000, 55000))
# combining two data sets
df.all <- rbind(df.content, df.customers)
# calculating dummies, max and min values of X for plotting
df.all <- df.all %>%
group_by(step) %>%
mutate(totnum = sum(number)) %>%
ungroup() %>%
mutate(dum = (max(totnum) - totnum)/2,
maxx = totnum + dum,
minx = dum)
# data frame for plotting funnel lines
df.lines <- df.all %>%
select(step, maxx, minx) %>%
group_by(step) %>%
unique()
# data frame with dummies
df.dum <- df.all %>%
select(step, dum) %>%
unique() %>%
mutate(content = 'dummy',
number = dum) %>%
select(content, step, number)
# data frame with rates
conv <- df.all$totnum[df.all$step == 'action']
df.rates <- df.all %>%
select(step, totnum) %>%
group_by(step) %>%
unique() %>%
ungroup() %>%
mutate(prevnum = lag(totnum),
rate = ifelse(step == 'new' | step == 'engaged' | step == 'loyal',
round(totnum / conv, 3),
round(totnum / prevnum, 3))) %>%
select(step, rate)
df.rates <- na.omit(df.rates)
# creting final data frame
df.all <- df.all %>%
select(content, step, number)
df.all <- rbind(df.all, df.dum)
df.all <- df.all %>%
group_by(step) %>%
arrange(desc(content)) %>%
ungroup()
# calculating position of labels
df.all <- df.all %>%
group_by(step) %>%
mutate(pos = cumsum(number) - 0.5*number)
# defining order of steps
df.all$step <- factor(df.all$step, levels = c('loyal', 'engaged', 'new', 'action', 'desire', 'interest', 'awareness'))
list <- c(unique(as.character(df.all$content)))
df.all$content <- factor(df.all$content, levels = c('dummy', c(list)))
# creating custom palette with 'white' color for dummies
cols <- c("#ffffff", "#fec44f", "#fc9272", "#a1d99b", "#fee0d2", "#2ca25f",
"#8856a7", "#43a2ca", "#fdbb84", "#e34a33",
"#a6bddb", "#dd1c77", "#ffeda0", "#756bb1")
# plotting chart
ggplot() +
theme_minimal() +
coord_flip() +
scale_fill_manual(values=cols) +
geom_bar(data=df.all, aes(x=step, y=number, fill=content), stat="identity", width=1) +
geom_text(data=df.all[df.all$content!='dummy', ],
aes(x=step, y=pos, label=paste0(content, '-', number/1000, 'K')),
size=4, color='white', fontface="bold") +
geom_ribbon(data=df.lines, aes(x=step, ymax=max(maxx), ymin=maxx, group=1), fill='white') +
geom_line(data=df.lines, aes(x=step, y=maxx, group=1), color='darkred', size=4) +
geom_ribbon(data=df.lines, aes(x=step, ymax=minx, ymin=min(minx), group=1), fill='white') +
geom_line(data=df.lines, aes(x=step, y=minx, group=1), color='darkred', size=4) +
geom_text(data=df.rates, aes(x=step, y=(df.lines$minx[-1]), label=paste0(rate*100, '%')), hjust=1.2,
color='darkblue', fontface="bold") +
theme(legend.position='none', axis.ticks=element_blank(), axis.text.x=element_blank(),
axis.title.x=element_blank())
Sales Funnel with R . by means of https://www.r-bloggers.com/
library(tidyverse)
library(purrrlyr)
library(reshape2)
##### simulating the "real" data #####
set.seed(454)
df_raw <- data.frame(customer_id = paste0('id', sample(c(1:5000), replace = TRUE)),
date = as.POSIXct(rbeta(10000, 0.7, 10) * 10000000, origin = '2017-01-01', tz = "UTC"),
channel = paste0('channel_', sample(c(0:7), 10000, replace = TRUE, prob = c(0.2, 0.12, 0.03, 0.07, 0.15, 0.25, 0.1, 0.08))),
site_visit = 1) %>%
mutate(two_pages_visit = sample(c(0,1),
10000,
replace = TRUE,
prob = c(0.8, 0.2)),
product_page_visit = ifelse(two_pages_visit == 1,
sample(c(0, 1),
length(two_pages_visit[which(two_pages_visit == 1)]),
replace = TRUE, prob = c(0.75, 0.25)),
0),
add_to_cart = ifelse(product_page_visit == 1,
sample(c(0, 1),
length(product_page_visit[which(product_page_visit == 1)]),
replace = TRUE, prob = c(0.1, 0.9)),
0),
purchase = ifelse(add_to_cart == 1,
sample(c(0, 1),
length(add_to_cart[which(add_to_cart == 1)]),
replace = TRUE, prob = c(0.02, 0.98)),
0)) %>%
dmap_at(c('customer_id', 'channel'), as.character) %>%
arrange(date) %>%
mutate(session_id = row_number()) %>%
arrange(customer_id, session_id)
df_raw <- melt(df_raw, id.vars = c('customer_id', 'date', 'channel', 'session_id'), value.name = 'trigger', variable.name = 'event') %>%
filter(trigger == 1) %>%
select(-trigger) %>%
arrange(customer_id, date)
df_customers <- df_raw %>%
group_by(customer_id, event) %>%
filter(date == min(date)) %>%
ungroup()
sf_probs <- df_customers %>%
group_by(event) %>%
summarise(customers_on_step = n()) %>%
ungroup() %>%
mutate(sf_probs = round(customers_on_step / customers_on_step[event == 'site_visit'], 3),
sf_probs_step = round(customers_on_step / lag(customers_on_step), 3),
sf_probs_step = ifelse(is.na(sf_probs_step) == TRUE, 1, sf_probs_step),
sf_importance = 1 - sf_probs_step,
sf_importance_weighted = sf_importance / sum(sf_importance)
)
df_customers_plot <- df_customers %>%
group_by(event) %>%
arrange(channel) %>%
mutate(pl = row_number()) %>%
ungroup() %>%
mutate(pl_new = case_when(
event == 'two_pages_visit' ~ round((max(pl[event == 'site_visit']) - max(pl[event == 'two_pages_visit'])) / 2),
event == 'product_page_visit' ~ round((max(pl[event == 'site_visit']) - max(pl[event == 'product_page_visit'])) / 2),
event == 'add_to_cart' ~ round((max(pl[event == 'site_visit']) - max(pl[event == 'add_to_cart'])) / 2),
event == 'purchase' ~ round((max(pl[event == 'site_visit']) - max(pl[event == 'purchase'])) / 2),
TRUE ~ 0
),
pl = pl + pl_new)
df_customers_plot$event <- factor(df_customers_plot$event, levels = c('purchase',
'add_to_cart',
'product_page_visit',
'two_pages_visit',
'site_visit'
))
# color palette
cols <- c('#4e79a7', '#f28e2b', '#e15759', '#76b7b2', '#59a14f',
'#edc948', '#b07aa1', '#ff9da7', '#9c755f', '#bab0ac')
ggplot(df_customers_plot, aes(x = event, y = pl)) +
theme_minimal() +
scale_colour_manual(values = cols) +
coord_flip() +
geom_line(aes(group = customer_id, color = as.factor(channel)), size = 0.05) +
geom_text(data = sf_probs, aes(x = event, y = 1, label = paste0(sf_probs*100, '%')), size = 4, fontface = 'bold') +
guides(color = guide_legend(override.aes = list(size = 2))) +
theme(legend.position = 'bottom',
legend.direction = "horizontal",
panel.grid.major.x = element_blank(),
panel.grid.minor = element_blank(),
plot.title = element_text(size = 20, face = "bold", vjust = 2, color = 'black', lineheight = 0.8),
axis.title.y = element_text(size = 16, face = "bold"),
axis.title.x = element_blank(),
axis.text.x = element_blank(),
axis.text.y = element_text(size = 8, angle = 90, hjust = 0.5, vjust = 0.5, face = "plain")) + ggtitle("Sales Funnel visualization - all customers journeys")
ref:https://www.r-bloggers.com/marketing-multi-channel-attribution-model-based-on-sales-funnel-with-r/
naniar package
gg_miss_case(airquality)
PGRdup
GN1 <- GN1000[!grepl("^ICG", GN1000$DonorID), ]
GN1$DonorID <- NULL
GN2 <- GN1000[grepl("^ICG", GN1000$DonorID), ]
GN2 <- GN2[!grepl("S", GN2$DonorID), ]
GN2$NationalID <- NULL
GN1$SourceCountry <- toupper(GN1$SourceCountry)
GN2$SourceCountry <- toupper(GN2$SourceCountry)
GN1$SourceCountry <- gsub("UNITED STATES OF AMERICA", "USA", GN1$SourceCountry)
GN2$SourceCountry <- gsub("UNITED STATES OF AMERICA", "USA", GN2$SourceCountry)
# Specify as a vector the database fields to be used
GN1fields <- c("NationalID", "CollNo", "OtherID1", "OtherID2")
GN2fields <- c("DonorID", "CollNo", "OtherID1", "OtherID2")
# Clean the data
GN1[GN1fields] <- lapply(GN1[GN1fields], function(x) DataClean(x))
GN2[GN2fields] <- lapply(GN2[GN2fields], function(x) DataClean(x))
y1 <- list(c("Gujarat", "Dwarf"), c("Castle", "Cary"), c("Small", "Japan"),
c("Big", "Japan"), c("Mani", "Blanco"), c("Uganda", "Erect"),
c("Mota", "Company"))
y2 <- c("Dark", "Light", "Small", "Improved", "Punjab", "SAM")
y3 <- c("Local", "Bold", "Cary", "Mutant", "Runner", "Giant", "No.",
"Bunch", "Peanut")
GN1[GN1fields] <- lapply(GN1[GN1fields], function(x) MergeKW(x, y1, delim = c("space", "dash")))
GN1[GN1fields] <- lapply(GN1[GN1fields], function(x) MergePrefix(x, y2, delim = c("space", "dash")))
GN1[GN1fields] <- lapply(GN1[GN1fields], function(x) MergeSuffix(x, y3, delim = c("space", "dash")))
GN2[GN2fields] <- lapply(GN2[GN2fields], function(x) MergeKW(x, y1, delim = c("space", "dash")))
GN2[GN2fields] <- lapply(GN2[GN2fields], function(x) MergePrefix(x, y2, delim = c("space", "dash")))
GN2[GN2fields] <- lapply(GN2[GN2fields], function(x) MergeSuffix(x, y3, delim = c("space", "dash")))
# Remove duplicated DonorID records in GN2
GN2 <- GN2[!duplicated(GN2$DonorID), ]
# Generate KWIC index
GN1KWIC <- KWIC(GN1, GN1fields)
GN2KWIC <- KWIC(GN2, GN2fields)
# Specify the exceptions as a vector
exep <- c("A", "B", "BIG", "BOLD", "BUNCH", "C", "COMPANY", "CULTURE",
"DARK", "E", "EARLY", "EC", "ERECT", "EXOTIC", "FLESH", "GROUNDNUT",
"GUTHUKAI", "IMPROVED", "K", "KUTHUKADAL", "KUTHUKAI", "LARGE",
"LIGHT", "LOCAL", "OF", "OVERO", "P", "PEANUT", "PURPLE", "R",
"RED", "RUNNER", "S1", "SAM", "SMALL", "SPANISH", "TAN", "TYPE",
"U", "VALENCIA", "VIRGINIA", "WHITE")
# Specify the synsets as a list
syn <- list(c("CHANDRA", "AH114"), c("TG1", "VIKRAM"))
GNdupc <- ProbDup(kwic1 = GN1KWIC, kwic2 = GN2KWIC, method = "c",
excep = exep, fuzzy = TRUE, phonetic = TRUE,
encoding = "primary", semantic = TRUE, syn = syn)
GNdupcView <- ViewProbDup(GNdupc, GN1, GN2, "SourceCountry", "SourceCountry",
max.count = 30, select = c("INDIA", "USA"), order = "type",
main = "Groundnut Probable Duplicates")
library(gridExtra)
grid.arrange(GNdupcView$SummaryGrob)
ref:https://cran.r-project.org/web/packages/PGRdup/PGRdup.pdf
persp-- Perspective Plots
layout(matrix(1:9, ncol = 3, byrow = T))
> par(mar = c(0,0,0,0))
>
> for(i in seq(0, 360, length.out = 9)) {
+ persp(x = axis.vector,
+ y = axis.vector,
+ z = z.axis.vector.2,main=""+ theta = i, phi = 15,col = "springgreen", expand = 0.6, shade = 0.3) }
persp
> f.sugakuart.com <- function(a, b, x, y) {
+ a * exp(- (x - y)^2 / b)
+ }
>
> z.axis.vector.2 <- outer(X = axis.vector, Y = axis.vector, function(X,Y) f.sugakuart.com(a = 1, b = 1, x = X, y = Y))
>
> persp(x = axis.vector,
+ y = axis.vector,
+ z = z.axis.vector.2,main="",
+ theta = 100, phi = 30,col = "springgreen", expand = 0.6, shade = 0.3)
persp-
> f.sugakuart.com <- function(a, b, x, y) {
+ a * exp(- (x - y)^2 / b)
+ }
>
> z.axis.vector.2 <- outer(X = axis.vector, Y = axis.vector, function(X,Y) f.sugakuart.com(a = 1, b = 1, x = X, y = Y))
>
> persp(x = axis.vector,
+ y = axis.vector,
+ z = z.axis.vector.2,main="",
+ theta = 120, phi = 15,col = "springgreen", expand = 0.6, shade = 0.3)
>
grDevices
persp function
F<-function(x, y){
+ sqrt(cos(x)+sin(y))
> x <- y <- seq(-1, 1, length= 20)
> z <- outer(x, y, F)
> persp(x, y, zn",
+ zlab = "z",
+ theta = 30, phi = 15,
+ col = "springgreen", shade = 0.5)
lattice package
my.settings <- list(
+ par.main.text = list(font = 2, # make it bold
+ just = "left",
+ x = grid::unit(5, "mm")))
>
> xyplot(sin(1:200) ~ cos(1:200),
+ par.settings=my.settings,
+ main=" ", sub=" ",
+ type="l")
diagram
ref: http://www.rforscience.com/portfolio/solving-differential-equations-in-r-chapter-5/
Plot
require(shape)
par (mar = c(1, 1, 1, 1))
emptyplot()
mid <- c(0.5, 0.9)
r <- 0.8
dpi <- 0.18
GE <- getellipse (mid = mid, from = (3/2-dpi)*pi, to = (3/2 + dpi)*pi,
rx = r, ry = r)
plotcircle(mid = mid, from = (3/2-dpi)*pi, to = (3/2 + dpi)*pi,
lty = 1, lcol = "pink", r = r)
segments(mid[1], mid[2], mid[1], mid[2] - r, lty = 2)
nr <- nrow(GE) * 0.8
bob <- GE[nr, ]
segments(mid[1], mid[2], bob[1], bob[2], lty = 1, lwd = 2)
plotcircle(mid = mid, from = 3/2*pi, to = (3/2 + dpi*0.5)*pi,
lty = 1, lcol = "purple", r = r, arrow = TRUE,
arr.adj = 1, arr.type = "triangle", arr.length = 0.3)
filledellipse( mid = bob, col = greycol(100), rx1 = 0.035)
filledellipse( mid = mid - c(0, r), col = greycol(100, interval = c(0, 0.4)),
rx1 = 0.035)
filledellipse( mid = mid, col = "black", rx1 = 0.01)
xa <- 0.75
ya <- 0.7
dd <- 0.15
Arrows(xa, ya, xa, ya+dd, arr.type = "triangle", arr.length = 0.2)
Arrows(xa, ya, xa+dd, ya, arr.type = "triangle", arr.length = 0.2)
text(xa + dd/2, ya - dd/4, "x")
text(xa - dd/4, ya + dd/2, "y")
text(0.68, 0.45, " length L", adj = 0)
text(bob[1] + dd/3, bob[2], "m = 2", adj = 0)
ref:http://www.rforscience.com/portfolio/solving-differential-equations-in-r-chapter-4/
Plot
require(OceanView)
> require(shape)
> cols <- ramp.col(c( "lightblue1", "green"), n = 50)
> par(mar = c(0, 0, 0, 1))
> image2D(Hypsometry, col = cols, shade = 0.08, rasterImage = TRUE,
+ contour = list(levels = 0, draw = F), axes = FALSE, main="", xlab = ", ylab = "",
+ colkey = list(width = 0.3, length = 0.3, cex.axis = 0.5))
>
Plot3D package
> url <- "http://seamap.env.duke.edu/species/180524"
>
> require(plot3D)
> # terms of use: citation of OBIS-SEAMAP
>
> Mink <- read.csv("species_180524_points.csv") [, c
>
> # project on a grid
> nbins <- 200
> xm <- seq(-180, 180, length.out = nbins)
> ym <- seq(-90, 90, length.out = nbins)
> xy <- table(cut(Mink$longitude, xm),
+ cut(Mink$latitude, ym))
> xy [xy == 0] <- NA
> xmid <- 0.5*(xm[-1] + xm[-nbins])
> ymid <- 0.5*(ym[-1] + ym[-nbins])
>
> par(oma = c(2, 0, 0, 0))
> ImageOcean(col = ramp.col (c("lightblue", "darkblue")), shade = 0.1,
+ contour = list(levels = 0), NAcol = "grey", colkey = list (plot = FALSE),
+ main = " Minkwhale - OBIS seamap")
>
> image2D(x = xmid, y = ymid, z = xy, log = "c", add = TRUE,
+ col = jet2.col(100), NAcol = "transparent", clab = "count")
GA
y <- x <- seq(-10, 10, length=60)
> f <- function(x,y) { r <- sqrt(x^2+y^4); 10 * 2*sin(2*r)/r }
> z <- outer(x, y, f)
> persp3D(x, y, z, theta = 45,main="by Volkan OBAN using R - GA ", phi = 30, expand = 0.5
radialpie
> library(HistData)
Warning message:
package ‘HistData’ was built under R version 3.4.1
> library(plotrix)
> data = Nightingale[13:24,]
radial.pie
vipPlot
vioplot.singmann <- function(x, ..., range = 1.5, h = NULL, ylim = NULL, names = NULL,
horizontal = FALSE, col = NULL, border = "black", lty = 1, lwd = 1, rectCol = "black",
colMed = "white", pchMed = 19, at, add = FALSE, wex = 1, mark.outlier = TRUE,
pch.mean = 4, ids = NULL, drawRect = TRUE, yaxt = "s") {
# process multiple datas
datas <- list(x, ...)
n <- length(datas)
if (missing(at))
at <- 1:n
# pass 1 - calculate base range - estimate density setup parameters for
# density estimation
upper <- vector(mode = "numeric", length = n)
lower <- vector(mode = "numeric", length = n)
q1 <- vector(mode = "numeric", length = n)
q3 <- vector(mode = "numeric", length = n)
med <- vector(mode = "numeric", length = n)
base <- vector(mode = "list", length = n)
height <- vector(mode = "list", length = n)
outliers <- vector(mode = "list", length = n)
baserange <- c(Inf, -Inf)
# global args for sm.density function-call
args <- list(display = "none")
if (!(is.null(h)))
args <- c(args, h = h)
for (i in 1:n) {
data <- datas[[i]]
if (!is.null(ids))
names(data) <- ids
if (is.null(names(data)))
names(data) <- as.character(1:(length(data)))
# calculate plot parameters 1- and 3-quantile, median, IQR, upper- and
# lower-adjacent
data.min <- min(data)
data.max <- max(data)
q1[i] <- quantile(data, 0.25)
q3[i] <- quantile(data, 0.75)
med[i] <- median(data)
iqd <- q3[i] - q1[i]
upper[i] <- min(q3[i] + range * iqd, data.max)
lower[i] <- max(q1[i] - range * iqd, data.min)
# strategy: xmin = min(lower, data.min)) ymax = max(upper, data.max))
est.xlim <- c(min(lower[i], data.min), max(upper[i], data.max))
# estimate density curve
smout <- do.call("sm.density", c(list(data, xlim = est.xlim), args))
# calculate stretch factor the plots density heights is defined in range 0.0
# ... 0.5 we scale maximum estimated point to 0.4 per data
hscale <- 0.4/max(smout$estimate) * wex
# add density curve x,y pair to lists
base[[i]] <- smout$eval.points
height[[i]] <- smout$estimate * hscale
t <- range(base[[i]])
baserange[1] <- min(baserange[1], t[1])
baserange[2] <- max(baserange[2], t[2])
min.d <- boxplot.stats(data)[["stats"]][1]
max.d <- boxplot.stats(data)[["stats"]][5]
height[[i]] <- height[[i]][(base[[i]] > min.d) & (base[[i]] < max.d)]
height[[i]] <- c(height[[i]][1], height[[i]], height[[i]][length(height[[i]])])
base[[i]] <- base[[i]][(base[[i]] > min.d) & (base[[i]] < max.d)]
base[[i]] <- c(min.d, base[[i]], max.d)
outliers[[i]] <- list(data[(data < min.d) | (data > max.d)], names(data[(data <
min.d) | (data > max.d)]))
# calculate min,max base ranges
}
# pass 2 - plot graphics setup parameters for plot
if (!add) {
xlim <- if (n == 1)
at + c(-0.5, 0.5) else range(at) + min(diff(at))/2 * c(-1, 1)
if (is.null(ylim)) {
ylim <- baserange
}
}
if (is.null(names)) {
label <- 1:n
} else {
label <- names
}
boxwidth <- 0.05 * wex
# setup plot
if (!add)
plot.new()
if (!horizontal) {
if (!add) {
plot.window(xlim = xlim, ylim = ylim)
axis(2)
axis(1, at = at, label = label)
}
box()
for (i in 1:n) {
# plot left/right density curve
polygon(c(at[i] - height[[i]], rev(at[i] + height[[i]])), c(base[[i]],
rev(base[[i]])), col = col, border = border, lty = lty, lwd = lwd)
if (drawRect) {
# browser() plot IQR
boxplot(datas[[i]], at = at[i], add = TRUE, yaxt = yaxt, pars = list(boxwex = 0.6 *
wex, outpch = if (mark.outlier) "" else 1))
if ((length(outliers[[i]][[1]]) > 0) & mark.outlier)
text(rep(at[i], length(outliers[[i]][[1]])), outliers[[i]][[1]],
labels = outliers[[i]][[2]])
# lines( at[c( i, i)], c(lower[i], upper[i]) ,lwd=lwd, lty=lty) plot 50% KI
# box rect( at[i]-boxwidth/2, q1[i], at[i]+boxwidth/2, q3[i], col=rectCol)
# plot median point points( at[i], med[i], pch=pchMed, col=colMed )
}
points(at[i], mean(datas[[i]]), pch = pch.mean, cex = 1.3)
}
} else {
if (!add) {
plot.window(xlim = ylim, ylim = xlim)
axis(1)
axis(2, at = at, label = label)
}
box()
for (i in 1:n) {
# plot left/right density curve
polygon(c(base[[i]], rev(base[[i]])), c(at[i] - height[[i]], rev(at[i] +
height[[i]])), col = col, border = border, lty = lty, lwd = lwd)
if (drawRect) {
# plot IQR
boxplot(datas[[i]], yaxt = yaxt, at = at[i], add = TRUE, pars = list(boxwex = 0.8 *
wex, outpch = if (mark.outlier) "" else 1))
if ((length(outliers[[i]][[1]]) > 0) & mark.outlier)
text(rep(at[i], length(outliers[[i]][[1]])), outliers[[i]][[1]],
labels = outliers[[i]][[2]])
# lines( at[c( i, i)], c(lower[i], upper[i]) ,lwd=lwd, lty=lty)
}
points(at[i], mean(datas[[i]]), pch = pch.mean, cex = 1.3)
}
}
invisible(list(upper = upper, lower = lower, median = med, q1 = q1, q3 = q3))
}
# plot
par(cex.main = 1.5, mar = c(5, 6, 4, 5) + 0.1, mgp = c(3.5, 1, 0), cex.lab = 1.5,
font.lab = 2, cex.axis = 1.3, bty = "n", las = 1)
x <- c(1, 2, 3, 4)
plot(x, c(-10, -10, -10, -10), type = "p", ylab = " ", xlab = " ", cex = 1.5,
ylim = c(0.3, 0.6), xlim = c(1, 4), lwd = 2, pch = 5, axes = F, main = " ")
axis(1, at = c(1.5, 2.5, 3.5), labels = c("HF", "LF", "VLF"))
axis(2, pos = 1.1)
mtext("Word Frequency", side = 1, line = 3, cex = 1.5, font = 2)
par(las = 0)
mtext("Group Mean M", side = 2, line = 2.9, cex = 1.5, font = 2)
x <- c(1.5, 2.5, 3.5)
vioplot.singmann(RT.hf.sp, RT.lf.sp, RT.vlf.sp, add = TRUE, mark.outlier = FALSE,
at = c(1.5, 2.5, 3.5), wex = 0.4, yaxt = "n")
vioplot.singmann(RT.hf.ac, RT.lf.ac, RT.vlf.ac, add = TRUE, mark.outlier = FALSE,
at = c(1.5, 2.5, 3.5), wex = 0.4, col = "grey", border = "grey", rectCol = "grey",
colMed = "grey", yaxt = "n")
text(2.5, 0.35, "Speed", cex = 1.4, font = 1, adj = 0.5)
text(2.5, 0.58, "Accuracy", cex = 1.4, font = 1, col = "grey", adj = 0.5)
ref:http://shinyapps.org/apps/RGraphCompendium/index.php
arulesViz
> data(Groceries)
> rules <- apriori(Groceries, parameter=list(support=0.005, confidence=0.5))
> plot(rules, method="grouped")
ref:http://www.ekonlab.com/?p=835
ggformula
gf_point(price~carat| color ~ clarity, data=diamonds, alpha=0.2) %>% gf_lm()
ggformula
ggplot(data = iris, aes(sample = Sepal.Length)) +
+ geom_qq() +
+ stat_qqline( alpha = 0.7, color = "red", linetype = "dashed") +
+ facet_wrap(~Species)
ggformula
> D <- expand.grid(x = 1:10, y=1:10)
> D$angle <- runif(100, 0, 2*pi)
> D$speed <- runif(100, 0, sqrt(0.1 * D$x))
> gf_point(y ~ x, data = D) %>%
+ gf_spoke(y ~ x, angle = ~angle, radius = 0.5)
> gf_point(y ~ x, data = D) %>%
+ gf_spoke(y ~ x, angle = ~angle, radius = ~speed)
ggformula
if (require(weatherData) & require(dplyr)) {
+ Temps <- NewYork2013 %>% mutate(city = "NYC") %>%
+ bind_rows(Mumbai2013 %>% mutate(city = "Mumbai")) %>%
+ bind_rows(London2013 %>% mutate(city = "London")) %>%
+ mutate(date = lubridate::date(Time),
+ month = lubridate::month(Time)) %>%
+ group_by(city, date) %>%
+ summarise(
+ hi = max(Temperature, na.rm = TRUE),
+ lo = min(Temperature, na.rm = TRUE),
+ mid = (hi + lo)/2
+ )
+ gf_ribbon(lo + hi ~ date, data = Temps, fill = ~city, alpha = 0.4) %>%
+ gf_theme(theme = theme_minimal())
+ gf_linerange(lo + hi ~ date | city ~ ., color = ~mid, data = Temps) %>%
+ gf_refine(scale_colour_gradientn(colors = rev(rainbow(5))))
+ gf_ribbon(lo + hi ~ date | city ~ ., data = Temps)
+ # Chaining in the data
+ Temps %>% gf_ribbon(lo + hi ~ date, alpha = 0.4) %>% gf_facet_grid(city ~ .)
+ }
ggformula
gf_dotplot(~ Sepal.Length, fill = ~Species, data = iris)
geofacet
> ggplot(eu_gdp, aes(year, gdp_pc)) +
+ geom_line(color = "steelblue") +
+ geom_hline(yintercept = 100, linetype = 2) +
+ facet_geo(~ name, grid = "eu_grid1") +
+ scale_x_continuous(labels = function(x) paste0("'", substr(x, 3, 4))) +
+ ylab("GDP Per Capita") +
+ theme_bw()
geofacet
> library(geofacet)
Warning message:
package ‘geofacet’ was built under R version 3.4.1
> library(ggplot2)
> # barchart of state rankings in various categories
> ggplot(state_ranks, aes(variable, rank, fill = variable)) +
+ geom_col() +
+ coord_flip() +
+ facet_geo(~ state) +
+ theme_bw()
Voronoi Diagrams
> set.seed(105)
> long<-rnorm(30,-100,18)
> lat<-rnorm(30,49,12)
> df <- data.frame(lat,long)
>
> library(deldir)
> library(ggplot2)
>
> #This creates the voronoi line segments
> voronoi <- deldir(df$long, df$lat)
>
> #Now we can make a plot
> ggplot(data=df, aes(x=long,y=lat)) +
+ #Plot the voronoi lines
+ geom_segment(
+ aes(x = x1, y = y1, xend = x2, yend = y2),
+ size = 2,
+ data = voronoi$dirsgs,
+ linetype = 1,
+ color= "pink") +
+ #Plot the points
+ geom_point(
+ fill=rgb(70,130,180,255,maxColorValue=255),
+ pch=21,
+ size = 4,
+ color="purple")
cartogram
> library(maptools)
> library(cartogram)
> library(rgdal)
> data(wrld_simpl)
> afr <- spTransform(wrld_simpl[wrld_simpl$REGION==2 & wrld_simpl$POP2005 > 0,],
+ CRS("+init=epsg:3395"))
> par(mfcol=c(1,2))
> plot(afr)
> plot(cartogram(afr, "POP2005", 3))
tripack-k-means and voronoi diagrams
set.seed(1)
pts <- cbind(X=rnorm(500,rep(seq(1,9,by=2)/10,100),.022),Y=rnorm(500,.5,.15))
km1 <- kmeans(pts, centers=5, nstart = 1, algorithm = "Lloyd")
There were 19 warnings (use warnings() to see them)
> library(tripack)
> library(RColorBrewer)
> CL5 <- brewer.pal(5, "Pastel1")
> V <- voronoi.mosaic(km1$centers[,1],km1$centers[,2])
> P <- voronoi.polygons(V)
> plot(pts,pch=19,xlim=0:1,ylim=0:1,xlab="",ylab="",col=CL5[km1$cluster])
> points(km1$centers[,1],km1$centers[,2],pch=3,cex=1.5,lwd=2)
> plot(V,add=TRUE)
ref:http://freakonometrics.hypotheses.org
scatterplot3d
data(Mishkin )
ref: ref: Visualizing Complex Data Using R by N.D. Lewis
tm and wordcloud
data(SOTU)# contains the text of the Presidential addresses.
> # we only want the words so we remove punctuation
> text <- tm_map(SOTU, removePunctuation)
> text <- tm_map(text, function(x)removeWords (x,stopwords()))
> # put cleaned data in appropriate format
> tdm <- TermDocumentMatrix(text)
> m <- as.matrix(tdm)
> v <- sort(rowSums(m),decreasing=TRUE)
> d <- data.frame(word = names(v),freq=v)
> par(bg="purple4")# set background color
> wordcloud(d$word,d$freq, random.order=FALSE,min.freq=6 ,
color="navajowhite")
ref:Visualizing Complex Data Using R
by N.D. Lewis
mvtsplot
ref: Visualizing Complex Data Using R
by N.D. Lewis
mvtsplot
> library(datasets)
> library(mvtsplot)
>D <- diff(EuStockMarkets ,90)
>mvtsplot(D,,norm ="internal", levels = 4,margin=FALSE)
spineplot
> r1 = c (7.9, 67.6, 28.3, 53.6)
> r2 = c (4.4, 54.5, 29.9, 57.6)
> r3 = c (10.2, 50, 27.7, 53.4)
> r4 = c (2.5, 35.3, 22.2, 47)
> r5 = c (8.5, 46.3, 32.2, 50)
> data <- as.table(rbind(r1,r2,r3,r4,r5))
> dimnames(data) <- list(x = c("volkan","oban", "V","O","VO"), R_spineplot = c("A (< 10)","B (<10)", "A (> 10)","B(> 10)"))
> spineplot(data)
Plot
> set.seed(345)
> Sector <- rep(c("S01","S02","S03","S04","S05","S06","S07"),times=7)
> Year <- as.numeric(rep(c("1950","1960","1970","1980","1990","2000","2010"),each=7))
> Value <- runif(49, 10, 100)
> data <- data.frame(Sector,Year,Value)
> ggplot(data, aes(x=Year, y=Value, fill=Sector)) +
+ geom_area(colour="black", size=.25, alpha=.4) + scale_fill_brewer(palette="Spectral", breaks=rev(levels(data$Sector))
plot3D
rect3D(x0 = 0.02, y0 = 0.25, z0 = 0.03, x1 = 1, z1 = 5,
+ ylim = c(0, 1), bty = "g", facets = TRUE",
+ border = "purple", col ="#7570B3", alpha=0.5,
+ lwd = 2, phi = 20)
Plot3D package
> data(iris)
> x <- sep.l <- iris$Sepal.Length
> y <- pet.l <- iris$Petal.Length
> z <- sep.w <- iris$Sepal.Width
> library(plot3D)
scatter3D(x, y, z, phi = 0, bty = "g", pch = 20, cex = 0.5)
> text3D(x, y, z, labels = rownames(iris), add = TRUE, colkey = FALSE, cex = 0.5)
ref: http://www.sthda.com
Plot3D package
> data(iris)
> x <- sep.l <- iris$Sepal.Length
> y <- pet.l <- iris$Petal.Length
> z <- sep.w <- iris$Sepal.Width
> library(plot3D)
Warning message:
package ‘plot3D’ was built under R version 3.4.1
> scatter3D(x, y, z, phi = 0, bty = "g", type = "b",
+ ticktype = "detailed", pch = 20,
+ cex = c(0.5, 1, 1.5))
ref:http://www.sthda.com
ggplot2
> y <- matrix(rnorm(500), 100, 5, dimnames=list(paste("g", 1:100, sep=""), paste("VO", 1:5, sep="")))
> y <- data.frame(Position=1:length(y[,1]), y)
>
> df <- melt(y, id.vars=c("Position"), variable.name = "VO", value.name="Values")
> p <- ggplot(df, aes(Position, Values)) + geom_line(aes(color=VO)) + facet_wrap(~VO, ncol=1)
> print(p)
> ggplot(df, aes(VO, Values, fill=VO)) + geom_boxplot()
>
ggplot2
> p <- ggplot(iris, aes(Sepal.Length, Sepal.Width)) +
+ geom_line(aes(color=Species), size=1) +
+ facet_wrap(~Species, ncol=1)
> p
> p
DATA ART with R
> theta = seq(0, 2*pi, length = 300)
> x = cos(theta)
> y = sin(theta)
>
> # set graphical parameters
> op = par(bg = "black", mar = rep(0.5, 4))
>
> # plot
> plot(x, y, type = 'n')
> segments(rep(0, 299), rep(0, 299), x[1:299] * runif(299, 0.5),
+ y[1:299] * runif(299, 0.7),
+ col = hsv(runif(95, 0.75, 0.85), 1, 1, runif(299, 0.5)),
+ lwd = 4*runif(299))
>
> # signature
> legend("topright", legend = "", bty = "n", text.col = "white")
Plot
> dat <- read.table(text = "A B C D E F G
+ 1 480 780 431 295 670 360 190
+ 2 720 350 377 255 340 615 345
+ 3 460 480 179 560 60 735 1260
+ 4 220 240 876 789 820 100 75", header = TRUE)
>
> library(reshape2)
>
> dat$row <- seq_len(nrow(dat))
> dat2 <- melt(dat, id.vars = "row")
>
> library(ggplot2)
Attaching package: ‘ggplot2’
The following objects are masked _by_ ‘.GlobalEnv’:
is.facet, midwest
>
> ggplot(dat2, aes(x=variable, y=value, fill=row)) +
+ geom_bar(stat="identity") +
+ xlab("\nType") +
+ ylab("Time\n") +
+ guides(fill=FALSE) +
+ theme_bw()
stripchart
set.seed(1); A <- sample(0:10, 100, replace = TRUE)
stripchart(A, method = "stack", offset = .5, at = .15, pch = 19,
main = "Dotplot of Random Values", xlab = "Random Values")
Plot
-
ref:Graphing Data with R.
FFtree
# Create FFTrees of the heart disease data
heart.fft <- FFTrees(formula = diagnosis ~.,
data = heartdisease)
# Visualise the tree
plot(heart.fft,
main = "Heart Disease Diagnosis",
decision.labels = c("Absent", "Present"))
FFtree
> heart.fft <- FFTrees(formula = diagnosis ~., data = heartdisease)
heart.fft
# Plot the best tree
plot(heart.fft)
ggalt-hrbrthemes
> library(hrbrthemes)
> library(ggalt)
> library(tidyverse)
> sports <- read_tsv("https://github.com/halhen/viz-pub/raw/master/sports-time-of-day/activity.tsv")
Parsed with column specification:
cols(
activity = col_character(),
time = col_double(),
p = col_double()
)
>
> sports %>%
+ group_by(activity) %>%
+ filter(max(p) > 3e-04,
+ !grepl('n\\.e\\.c', activity)) %>%
+ arrange(time) %>%
+ mutate(p_peak = p / max(p),
+ p_smooth = (lag(p_peak) + p_peak + lead(p_peak)) / 3,
+ p_smooth = coalesce(p_smooth, p_peak)) %>%
+ ungroup() %>%
+ do({
+ rbind(.,
+ filter(., time == 0) %>%
+ mutate(time = 24*60))
+ }) %>%
+ mutate(time = ifelse(time < 3 * 60, time + 24 * 60, time)) %>%
+ mutate(activity = reorder(activity, p_peak, FUN=which.max)) %>%
+ arrange(activity) %>%
+ mutate(activity.f = reorder(as.character(activity), desc(activity))) -> sports
>
> sports <- mutate(sports, time2 = time/60)
>
> ggplot(sports, aes(time2, p_smooth)) +
+ geom_horizon(bandwidth=0.1) +
+ facet_grid(activity.f~.) +
+ scale_x_continuous(expand=c(0,0), breaks=seq(from = 3, to = 27, by = 3), labels = function(x) {sprintf("%02d:00", as.integer(x %% 24))}) +
+ viridis::scale_fill_viridis(name = "Activity relative to peak", discrete=TRUE,
+ labels=scales::percent(seq(0, 1, 0.1)+0.1)) +
+ labs(x=NULL, y=NULL, title="by Volkan OBAN using R - ggalt and hrbrthemes \n \n Peak time of day for sports and leisure",
+ subtitle="Number of participants throughout the day compared to peak popularity.") +
+ theme_ipsum_rc(grid="") +
+ theme(panel.spacing.y=unit(-0.05, "lines")) +
+ theme(strip.text.y = element_text(hjust=0, angle=360)) +
+ theme(axis.text.y=element_blank())
dumbbell plot
library(ggplot2) # devtools::install_github("hadley/ggplot2")
library(ggalt) # devtools::install_github("hrbrmstr/ggalt")
library(dplyr) # for data_frame() & arrange()
# I'm not crazy enough to input all the data; this will have to do for the example
df <- data_frame(country=c("Germany", "France", "Vietnam", "Japan", "Poland", "Lebanon",
"Australia", "SouthnKorea", "Canada", "Spain", "Italy", "Peru",
"U.S.", "UK", "Mexico", "Chile", "China", "India"),
ages_35=c(0.39, 0.42, 0.49, 0.43, 0.51, 0.57,
0.60, 0.45, 0.65, 0.57, 0.57, 0.65,
0.63, 0.59, 0.67, 0.75, 0.52, 0.48),
ages_18_to_34=c(0.81, 0.83, 0.86, 0.78, 0.86, 0.90,
0.91, 0.75, 0.93, 0.85, 0.83, 0.91,
0.89, 0.84, 0.90, 0.96, 0.73, 0.69),
diff=sprintf("+%d", as.integer((ages_18_to_34-ages_35)*100)))
# we want to keep the order in the plot, so we use a factor for country
df <- arrange(df, desc(diff))
df$country <- factor(df$country, levels=rev(df$country))
# we only want the first line values with "%" symbols (to avoid chart junk)
# quick hack; there is a more efficient way to do this
percent_first <- function(x) {
x <- sprintf("%d%%", round(x*100))
x[2:length(x)] <- sub("%$", "", x[2:length(x)])
x
}
gg <- ggplot()
# doing this vs y axis major grid line
gg <- gg + geom_segment(data=df, aes(y=country, yend=country, x=0, xend=1), color="#b2b2b2", size=0.15)
# dum…dum…dum!bell
gg <- gg + geom_dumbbell(data=df, aes(y=country, x=ages_35, xend=ages_18_to_34),
size=1.5, color="#b2b2b2", point.size.l=3, point.size.r=3,
point.colour.l="#9fb059", point.colour.r="#edae52")
# text below points
gg <- gg + geom_text(data=filter(df, country=="Germany"),
aes(x=ages_35, y=country, label="Ages 35+"),
color="#9fb059", size=3, vjust=-2, fontface="bold", family="Calibri")
gg <- gg + geom_text(data=filter(df, country=="Germany"),
aes(x=ages_18_to_34, y=country, label="Ages 18-34"),
color="#edae52", size=3, vjust=-2, fontface="bold", family="Calibri")
# text above points
gg <- gg + geom_text(data=df, aes(x=ages_35, y=country, label=percent_first(ages_35)),
color="#9fb059", size=2.75, vjust=2.5, family="Calibri")
gg <- gg + geom_text(data=df, color="#edae52", size=2.75, vjust=2.5, family="Calibri",
aes(x=ages_18_to_34, y=country, label=percent_first(ages_18_to_34)))
# difference column
gg <- gg + geom_rect(data=df, aes(xmin=1.05, xmax=1.175, ymin=-Inf, ymax=Inf), fill="#efefe3")
gg <- gg + geom_text(data=df, aes(label=diff, y=country, x=1.1125), fontface="bold", size=3, family="Calibri")
gg <- gg + geom_text(data=filter(df, country=="Germany"), aes(x=1.1125, y=country, label="DIFF"),
color="#7a7d7e", size=3.1, vjust=-2, fontface="bold", family="Calibri")
gg <- gg + scale_x_continuous(expand=c(0,0), limits=c(0, 1.175))
gg <- gg + scale_y_discrete(expand=c(0.075,0))
gg <- gg + labs(x=NULL, y=NULL, title="The social media age gap",
subtitle="Adult internet users or reported smartphone owners whonuse social networking sites",
caption="Source: Pew Research Center, Spring 2015 Global Attitudes Survey. Q74")
gg <- gg + theme_bw(base_family="Calibri")
gg <- gg + theme(panel.grid.major=element_blank())
gg <- gg + theme(panel.grid.minor=element_blank())
gg <- gg + theme(panel.border=element_blank())
gg <- gg + theme(axis.ticks=element_blank())
gg <- gg + theme(axis.text.x=element_blank())
gg <- gg + theme(plot.title=element_text(face="bold"))
gg <- gg + theme(plot.subtitle=element_text(face="italic", size=9, margin=margin(b=12)))
gg <- gg + theme(plot.caption=element_text(size=7, margin=margin(t=12), color="#7a7d7e"))
gg
ggjoy
ref :http://lenkiefer.com/2017/08/03/joyswarm
ggjoy
set.seed(123)
dt<- data.frame('label'=rep(letters[1:10], each=100),
'value'=as.vector(mapply(rnorm, rep(100, 10), rnorm(10), SIMPLIFY=TRUE)),
'rank'=rep(1:5, each=100, times=20))
ggplot(dt, aes(x=value, y=label, fill=label)) +
+ geom_joy(scale=3, rel_min_height=0.01) +
+ scale_fill_manual(values=rep(c('pink4', 'darkviolet'), length(unique(joy$label))/2)) +
+ scale_y_discrete(expand = c(0.01, 0)) +
+ xlab('Value') +
+ theme_joy() +
+ theme(axis.title.y = element_blank(),
+ legend.position='none')
gjoy
> p1 = ggtree(tr) %<+% d1 +
+ geom_tippoint(aes(color=location), size=5) +
+ geom_tiplab(offset=-0.01, hjust=0.5, colour="white", size=3, fontface="bold") + ggtitle("by Volkan OBAN using R - ggjoy") +
+ scale_colour_manual(values = c("purple", "pink", "yellow")) +
+ scale_fill_manual(values = c("purple", "pink", "yellow"))
>
> facet_plot(p1, panel="Joy Plot", data=d4, geom_joy,
+ mapping = aes(x=val, group=label, fill=location), colour="grey40", lwd=0.3)
ref:https://stackoverflow.com/questions/45384281/ggjoy-facet-with-ggtree
gjoy
> require(ggtree)
> require(ggstance)
> # generate tree
> tr <- rtree(30)
>
> # create simple ggtree object with tip labels
> p <- ggtree(tr) + geom_tiplab(offset = 0.02)
>
> # Generate categorical data for each "species"
> d1 <- data.frame(id=tr$tip.label, location=sample(c("GZ", "HK", "CZ"), 30, replace=TRUE))
>
> #Plot the categorical data as colored points on the tree tips
> p1 <- p %<+% d1 + geom_tippoint(aes(color=location))
>
> # Generate distribution of points for each species
> d4 = data.frame(id=rep(tr$tip.label, each=20),
+ val=as.vector(sapply(1:30, function(i)
+ rnorm(20, mean=i)))
+ )
>
> require(ggjoy)
>
> ggplot(d4, aes(x = val, y = id)) +
+ geom_joy(scale = 2, rel_min_height=0.03) +
+ scale_y_discrete(expand = c(0.01, 0)) + theme_joy() + ggtitle("by Volkan OBAN using R - ggjoy")
Picking joint bandwidth of 0.439
> p <- ggtree(tr) + geom_tiplab(offset = 0.02);p1 <- p %<+% d1 + geom_tippoint(aes(color=location));facet_plot(p1, panel="Joy Plot", data=d4, geom_joy,
+ mapping = aes(x=val, group=label, fill=location), colour="grey50", lwd=0.3)
ggjoy
> set.seed(1234)
> pois_data <- data.frame(mean = rep(1:5, each = 10))
> pois_data$group <- factor(pois_data$mean, levels=5:1)
> pois_data$value <- rpois(nrow(pois_data), pois_data$mean)
>
> # make plot
> ggplot(pois_data, aes(x = value, y = group, group = group)) +
+ geom_joy2(aes(fill = group), stat = "binline", binwidth = 1, scale = 0.95) +
+ geom_text(stat = "bin",
+ aes(y = group + 0.95*(..count../max(..count..)),
+ label = ifelse(..count..>0, ..count.., "")),
+ vjust = 1.4, size = 3, color = "white", binwidth = 1) +
+ scale_x_continuous(breaks = c(0:12), limits = c(-.5, 13), expand = c(0, 0),
+ name = "random value") +
+ scale_y_discrete(expand = c(0.01, 0), name = "Poisson mean",
+ labels = c("5.0", "4.0", "3.0", "2.0", "1.0")) +
+ scale_fill_cyclical(values = c("#0000B0", "#7070D0")) +
+ labs(title = " Poisson random samples with different means",
+ subtitle = "sample size n=10") +
+ guides(y = "none") +
+ theme_joy(grid = FALSE) +
+ theme(axis.title.x = element_text(hjust = 0.5),
+ axis.title.y = element_text(hjust = 0.5))
ref: https://cran.r-project.org/web/packages/ggjoy/vignettes/gallery.html
ggjoy
> library(ggplot2movies)
> ggplot(movies[movies$year>1912,], aes(x = length, y = year, group = year)) +
+ geom_joy(scale = 10, size = 0.25, rel_min_height = 0.03) +
+ theme_joy() +
+ scale_x_continuous(limits=c(1, 200), expand = c(0.01, 0)) +
+ scale_y_reverse(breaks=c(2000, 1980, 1960, 1940, 1920, 1900), expand = c(0.01, 0))
ggjoy
ggplot(diamonds, aes(x = price, y = cut, fill = cut)) +
+ geom_joy(scale = 4) +
+ scale_fill_cyclical(values = c("purple", "pink"))
ggjoy
> library(ggjoy)
Warning message:
package ‘ggjoy’ was built under R version 3.4.1
>
> ggplot(diamonds, aes(x = price, y = cut)) +
+ geom_joy(scale = 4) + theme_joy() +
+ scale_y_discrete(expand = c(0.01, 0)) + # will generally have to set the `expand` option
+ scale_x_continuous(expand = c(0, 0))
cowplot
a<- qplot(color, price/carat, data = diamonds, geom = "jitter", alpha = I(1/15))
ggdraw(a) +
+ draw_plot_label("R - Data Visualization-data(diamonds)", size = 12) +
+ draw_label("", angle = 25, size = 50, alpha = .7)
cowplot
a<-ggplot(data=diamonds,aes(x=price, group=cut, fill=cut)) +
geom_density(adjust=1.5, position="fill")
ggdraw(a) +
+ draw_plot_label("Data Science & Analytics", size = 8) +
+ draw_label("", angle = 45, size = 40, alpha = .6)
cowplot
ggdraw
lattice package
df <- data.frame(expand.grid(1:100,1:100),rep(10,1000)) ;colnames(df) <- c("x","y","z"); wireframe(z~x*y,df,colorkey=TRUE,drape=TRUE);wireframe(z~x*y,df,main="",color="",drape=TRUE, zlim=c(0,24))
ggjoy
> require(ggplot2movies)
> require(viridis)
> ggplot(movies[movies$year>1989,], aes(x = length, y = year, fill = factor(year))) +
+ stat_binline(scale = 1.9, bins = 40) +
+ theme_joy() + theme(legend.position = "none") +
+ scale_x_continuous(limits = c(1, 180), expand = c(0.01, 0)) +
+ scale_y_reverse(expand = c(0.01, 0)) +
+ scale_fill_viridis(begin = 0.3, discrete = TRUE, option = "B") +
+ labs(title = " Movie lengths 1990 - 2005")
ggjoy
ggplot(iris, aes(x = Sepal.Length, y = Species, group = Species)) +
+ geom_joy(rel_min_height = 0.005) +
+ scale_y_discrete(expand = c(0.01, 0)) +
+ scale_x_continuous(expand = c(0.01, 0)) +
+ theme_joy()
persp-- Perspective Plots
cone <- function(x, y){ sqrt(x*cos(x^2)+sin(y)) } ;x <- y <- seq(-1, 1, length= 50); z <- outer(x, y, cone); persp(x, y, z, main="" ,col="pink")
GA
y <- x <- seq(-10, 10, length=60)
f <- function(x,y) { r <- sqrt(x^2+y^2); 10 * sin(r)/r }
z <- outer(x, y, f)
persp3D(x, y, z, color.palette = heat.colors, phi = 30, theta = 225,
box = TRUE, border = NA, shade = .4)
lattice package
df <- data.frame(expand.grid(1:10,1:10),rep(10,100)) ;colnames(df) <- c("x","y","z"); wireframe(z~x*y,df,colorkey=TRUE,drape=TRUE);wireframe(z~x*y,df,main="",colorkey=TRUE,drape=TRUE, zlim=c(0,24))
ggplot2
gplot(mtcars, aes(wt, mpg)) +
+ geom_point(shape = 21, colour = "purple", fill = "slateblue1", size = 5, stroke = 5) + theme_solarized() +
+ scale_colour_solarized("blue")
ggplot2
library("tidyverse")
library("forcats")
library(ggthemes)
rincome_plot <-
gss_cat %>%
ggplot(aes(rincome)) +
geom_bar()
rincome_plot
gss_cat %>%
filter(!denom %in% c("No answer", "Other", "Don't know", "Not applicable",
"No denomination")) %>%
count(relig)
gss_cat %>%
count(relig, denom) %>%
ggplot(aes(x = relig, y = denom, size = n)) +
geom_point() +
theme(axis.text.x = element_text(angle = 90) + theme_igray()
ref:https://jrnold.github.io/e4qf/factors.html
ggplot2
> dataframe <- tibble(
+ x = rnorm(10000),
+ y = rnorm(10000) )
ggplot(dataframe , aes(x, y)) +
+ geom_hex() +
+ scale_fill_gradient(low = "thistle2", high = "purple") +
+ coord_fixed()
ggplot2
> ggplot(mpg, aes(displ, hwy, colour = class)) +
+ geom_point(aes(colour = class)) +
+ geom_smooth(method = "lm", se = FALSE) +
+ labs(
+ title = "Fuel efficiency generally decreases with engine size",
+ subtitle = "Subcompact cars show the greatest sensitivity to engine size",
+ caption = "Data from fueleconomy.gov"
+ )
ggplot2
> library(gapminder)
Warning message:
package ‘gapminder’ was built under R version 3.4.1
> lifeExp ~ poly(year, 2)
lifeExp ~ poly(year, 2)
> country_model <- function(df) {
+ lm(lifeExp ~ poly(year - median(year), 2), data = df)
+ }
>
> by_country <- gapminder %>%
+ group_by(country, continent) %>%
+ nest()
>
> by_country <- by_country %>%
+ mutate(model = map(data, country_model))
> by_country <- by_country %>%
+ mutate(
+ resids = map2(data, model, add_residuals)
+ )
> by_country
unnest(by_country, resids) %>%
+ ggplot(aes(year, resid)) +
+ geom_line(aes(group = country), alpha = 1 / 3) +
+ geom_smooth(se = FALSE)
treemap
World population 2014
lattice package
> params.grid.length <- 20
> params.alpha.list <- seq(0.3, 0.6, length = params.grid.length)
> params.beta.list <- seq(1,9, length = params.grid.length)
> z <- matrix(ncol = params.grid.length, nrow = params.grid.length)
>
> # Loop through and calculate negative log likelihood at defined values in grid
> for (i in 1:length(params.alpha.list )){
+ for (ii in 1:length(params.beta.list)){
+ alpha <- params.alpha.list[i]
+ beta <- params.beta.list[ii]
+ y <- 0.5 + (1 - 0.5 - 0.025)* pweibull(resp.frame$x, beta, alpha)
+ negLog <- -sum(resp.frame$ny * log(y) + (resp.frame$num.tr - resp.frame$ny) * log(1 - y) ) # Negative log likelihood
+ z[i,ii] <- negLog
+ }
+ }
>
> # Need to generate stacked list of values to pass to wireframe in lattice
> params.alpha.wireList <- rep(unique(params.alpha.list),params.grid.length)
> params.beta.wireList <- rep(unique(params.beta.list),params.grid.length)
>
> temp <- stack(data.frame(z))
> negLog <- subset(temp, select=c(values))
> df.wireFrame <- data.frame(params.alpha.wireList,params.beta.wireList,negLog)
>
> # Plot parameter space
> wirePlot <- wireframe(values ~ params.alpha.wireList*params.beta.wireList, data=df.wireFrame, drape = TRUE,
+ col="purple",main="by Volkan OBAN using R - lattice",
+ col.regions = rainbow(100, s = 1, v = 1, start = 0, end = max(1,100-1)/100, alpha = 0.5),
+ xlab="Alpha", ylab="Beta", zlab="NLL",
+ screen = list (z = -140, x = -70, y = 3),
+ scales = list(arrows=FALSE,cex=.5,tick.number = 10))
> wirePlot
>
ggplot2
ref:http://rgraphgallery.blogspot.com.tr/2013/04/rg28-contour-plot.html
> require(ggplot2)
Zorunlu paket yükleniyor: ggplot2
> plt <- ggplot(gdr, aes(xvar, yvar, z= zvar)) + ggtitle("by Volkan OBAN using R - lattice \n contourplot - data:gdr ")
> plt + stat_contour() + theme_bw()
> plt + geom_tile(aes(fill = zvar)) + stat_contour() + theme_bw()
> plt + stat_contour(geom="polygon", aes(fill=..level..)) + theme_bw()
> require(ggplot2)
> plt <- ggplot(gdr, aes(xvar, yvar, z= zvar))
> plt + stat_contour() + theme_bw()
> plt + geom_tile(aes(fill = zvar)) + stat_contour() + theme_bw()
> plt + stat_contour(geom="polygon", aes(fill=..level..)) + theme_bw()
>
ggplot2
> require(ggplot2)
> plt <- ggplot(gdr, aes(xvar, yvar, z= zvar))
> plt + stat_contour() + theme_bw()
lattice package
> xvr <- seq(-5, 5, len = 50)
> yvr <- seq(-5, 5, len = 50)
> gdr <- expand.grid(xvar = xvr, yvar = yvr)
> gdr$zvar <- rnorm (nrow(gdr), 4, 1)
>
>
> #plot
> require(lattice)
> contourplot(zvar ~ xvar * yvar, data = gdr,main="by Volkan OBAN using R - lattice", cuts = 10)
> xvr <- seq(-5, 5, len = 50)
> yvr <- seq(-5, 5, len = 50)
> gdr <- expand.grid(xvar = xvr, yvar = yvr)
> gdr$zvar <- rnorm (nrow(gdr), 4, 1)
lattice package
> x <- seq(1,2,0.2);
> y <- seq(0.5,1.5,0.1);
>
> data1 <- matrix(0,nrow=length(x)*length(y),ncol=3);
> data2 <- matrix(0,nrow=length(x)*length(y),ncol=3);
>
> n <- 0;
> j <- 1;
> while(j<=length(x)){
+ for (k in 1:length(y)){
+ data1[k+n,1] <- x[j];
+ data1[k+n,2] <- y[k];
+ data1[k+n,3] <- x[j]^4 + y[k];
+
+ data2[k+n,1] <- x[j];
+ data2[k+n,2] <- y[k];
+ data2[k+n,3] <- x[j]^4 + y[k]^4 + 3;
+ }
+ n <- n+length(y);
+ j <- j+1;
+ }
> rm(x,y,j,n,k)
>
> # Arranging data into a data frame
> data1_2 <-as.data.frame(rbind(data1,data2));
> colnames(data1_2) <- c("x","y","z");
> data1_2$group <- gl(2, nrow(data1_2)/2, labels=c("data1", "data2"))
> rm(data1,data2)
>
> # Plotting data as a surface
> wireframe(z~x*y,data=data1_2,groups=group,
+
+ # Naming labels and Axis
+ main =list(label="by Volkan OBAN using R - lattice - wireframe ",cex=2,distance=5),
+ zlab=list(rot=90,label = "Z",cex=2),
+ xlab=list(label = "X",cex=2),
+ ylab=list(label = "Y",cex=2),
+
+ # Coloring the groups
+ col.groups=c(rgb(red=200,green=100,blue=80,
+ alpha=200,maxColorValue=255), # Orange
+ rgb(red=150,green=200,blue=205,
+ alpha=200,maxColorValue=255)), # Blue
+
+ # Coloring the grids
+ col=c(rgb(red=0,green=0,blue=0,alpha=50,maxColorValue=255),
+ rgb(red=0,green=0,blue=0,alpha=50,maxColorValue=255)),
+
+ aspect=c(1,1), # y-size/x-size and z-size/x-size
+ screen = list(z=40,y=0,x=-80)); # axis rotation
>
lattice package
> df <- data.frame(expand.grid(1:10,1:10),rep(10,100))
> colnames(df) <- c("x","y","z")
> wireframe(z~x*y,df,colorkey=TRUE,drape=TRUE)
>wireframe(z~x*y,df,main="",colorkey=TRUE,drape=TRUE, zlim=c(0,10))
lattice package
ref:http://zoonek.free.fr/blosxom/R/2006-08-10_R_Graphics.html
# Minimum Spanning Tree (MST)
panel.mst <- function (x, y, ...) {
require(ape) # For mst()
d <- dist(cbind(x,y))
m <- mst(d)
i <- which(m == 1)
panel.segments(x[row(m)[i]], y[row(m)[i]],
x[col(m)[i]], y[col(m)[i]],
...)
}
# 2-dimensional Kernel Density Estimation
panel.kde <- function (x, y, ...) {
require(grid) # for convertX() and unit()
require(MASS) # For kde2d()
k <- kde2d(
x, y,
n = 500,
# The limits of the current plot
lims = c(as.numeric(convertX(unit(0,"npc"),"native")),
as.numeric(convertX(unit(1,"npc"),"native")),
as.numeric(convertY(unit(0,"npc"),"native")),
as.numeric(convertY(unit(1,"npc"),"native"))))
panel.levelplot(rep(k$x, length(k$y)),
rep(k$y, each = length(k$x)),
sqrt(k$z),
subscripts = 1:length(k$z),
...)
}
# The same example as above
library(RColorBrewer)
xyplot(lat ~ long | Depth, data = quakes,
panel = function (x, y, ...) {
panel.kde(x, y,
col.regions = brewer.pal(9, "YlOrRd"))
panel.mst(x, y,
col = "black", lwd = 2)
},
strip = strip.custom(strip.names = TRUE,
strip.levels = TRUE),
par.strip.text = list(cex = 0.75),
aspect = "iso")
Plot3D package
X <- seq(0, pi, length.out = 50)
>
> Y <- seq(0, 2*pi, length.out = 50)
>
> M <- mesh(X, Y)
>
> phi <- M$x
>
> theta <- M$y
>
> # x, y and z grids
> x <- sin(phi) * cos(theta)
>
> y <- cos(phi)
>
> z <- sin(phi) * sin(theta)
>
> # these are the defaults
> p <- list(ambient = 0.3, diffuse = 0.6, specular = 1.,exponent = 20, sr = 0, alpha = 1)
>
> par(mfrow = c(3, 3), mar = c(0, 0, 0, 0))
>
> Col <- "magenta4"
>
> surf3D(x, y, z, box = FALSE, col = Col, lighting = TRUE)
> surf3D(x, y, z, box = FALSE, col = Col, lighting = list(exponent = 5))
> surf3D(x, y, z, box = FALSE, col = Col, lighting = list(exponent = 50))
> surf3D(x, y, z, box = FALSE, col = Col, shade = 0.9)
> surf3D(x, y, z, box = FALSE, col = Col, lighting = list(sr = 1))
> surf3D(x, y, z, box = FALSE, col = Col, lighting = list(diffuse = 0))
> surf3D(x, y, z, box = FALSE, col = Col, lighting = list(exponent = 50))
> surf3D(x, y, z, box = FALSE, col = Col, lighting = list(exponent = 20))
> surf3D(x, y, z, box = FALSE, col = Col, lighting = list(exponent = 1))
>
Plot3D package
image2D
Plot3D package
box3D(x0 = runif(4), y0 = runif(4), z0 = runif(4),
+ x1 = runif(4), y1 = runif(4), z1 = runif(4),
+ col = c("purple", "pink", "lightpink4"), alpha = 0.5,
+ border = "black", lwd = 2)
Plot3D package
z <- seq(0, 10, 0.2)
> x <- cos(z)
> y <- sin(z)*z
> scatter3D(x, y, z, phi = 0, bty = "g", type = "h", ticktype = "detailed")
Plot3D package
x <- y <- z <- seq(-1, 1, by = 0.1)
> grid <- mesh(x, y, z)
> colvar <- with(grid, x*exp(-x^2 - y^2 - z^2))
slice3D (x, y, z, colvar = colvar, theta = 60)
> slicecont3D (x, y, z, ys = seq(-1, 1, by = 0.5), colvar = colvar, theta = 60, border = "purple")
Plot3D package
a <- volcano[seq(1, 87, 15), seq(1, 61, 15)]
hist3D(z = a, scale = FALSE, expand = 0.01, bty = "g", phi = 20,
+ col = "#9932CC", border = "white", shade = 0.2, ltheta = 90, space = 0.3, ticktype = "detailed", d = 2)
Plot3D package
rect3D(x0 = seq(-0.8, -0.1, by = 0.1),
+ y0 = seq(-0.8, -0.1, by = 0.1),
+ z0 = seq(-0.8, -0.1, by = 0.1),
+ x1 = seq(0.8, 0.1, by = -0.1),
+ y1 = seq(0.8, 0.1, by = -0.1),
+ col = rainbow(8), border = "pink",
+ bty = "g", lwd = 2, phi = 20, main = " rect3D")
Plot3D package
box3D(x0 = seq(-0.8, -0.1, by = 0.1),
+ y0 = seq(-0.8, -0.1, by = 0.1),
+ z0 = seq(-0.8, -0.1, by = 0.1),
+ x1 = seq(0.8, 0.1, by = -0.1),
+ y1 = seq(0.8, 0.1, by = -0.1),
+ z1 = seq(0.8, 0.1, by = -0.1),
+ col = rainbow(n = 8, alpha = 0.1),
+ border = "purple", lwd = 2, phi = 20)
ref: https://rpubs.com/yoshio/95844
Plot3D package
> border3D(x0 = seq(-0.8, -0.1, by = 0.1),
+ y0 = seq(-0.8, -0.1, by = 0.1),
+ z0 = seq(-0.8, -0.1, by = 0.1),
+ x1 = seq(0.8, 0.1, by = -0.1),
+ y1 = seq(0.8, 0.1, by = -0.1),
+ z1 = seq(0.8, 0.1, by = -0.1),
+ col = rainbow(8), lty = 2,
+ lwd = c(1, 4), phi = 20, main = "")
Plot3D package
with (mtcars, {
# linear regression
fit <- lm(mpg ~ wt + disp)
# predict values on regular xy grid
wt.pred <- seq(1.5, 5.5, length.out = 30)
disp.pred <- seq(71, 472, length.out = 30)
xy <- expand.grid(wt = wt.pred,
disp = disp.pred)
mpg.pred <- matrix (nrow = 30, ncol = 30,
data = predict(fit, newdata = data.frame(xy),
interval = "prediction"))
# fitted points for droplines to surface
fitpoints <- predict(fit)
scatter3D(z = mpg, x = wt, y = disp, pch = 18, cex = 2,
theta = 20, phi = 20, ticktype = "detailed",
xlab = "wt", ylab = "disp", zlab = "mpg",
surf = list(x = wt.pred, y = disp.pred, z = mpg.pred,
facets = NA, fit = fitpoints),
main = "")
})
ref:https://rpubs.com/yoshio/95844
Plot3D package
reference:https://rpubs.com/yoshio/95844
> X <- seq(0, pi, length.out = 50)
> Y <- seq(0, 2*pi, length.out = 50)
> M <- mesh(X, Y)
> phi <- M$x
> theta <- M$y
> r <- sin(4*phi)^3 + cos(2*phi)^3 + sin(6*theta)^2 + cos(6*theta)^4
> x <- r * sin(phi) * cos(theta)
> y <- r * cos(phi)
> z <- r * sin(phi) * sin(theta)
> surf3D(x, y, z, colvar = y, colkey = FALSE, shade = 0.5,box = FALSE, theta = 60)
> surf3D(x, y, z, colvar = y, colkey = FALSE, box = FALSE, theta = 60, facets = FALSE
Plot3D package
> x <- rchisq(1000, df = 5)
> hs <- hist(x, breaks = 20)
hist3D(x = hs$mids, y = 1, z = matrix(ncol = 1, data = hs$density), bty = "g", ylim = c(0., 2.0), scale = FALSE, expand = 20, border = "pink", col = "red", shade = 0.4, space = 0.1, theta = 20, phi = 20, main = "")
Plot3D package
volkan <- volcano[seq(1, 87, 15), seq(1, 61, 15)]
ribbon3D(z = volkan, scale = FALSE, expand = 0.01, bty = "g", phi = 20, col = "pink", border = "purple", shade = 0.2, ltheta = 90,space = 0.3, ticktype = "detailed", d = 2, curtain = TRUE)
Plot3D package
hist3D
Plot3D package
> x <- y <- z <- seq(-4, 4, by = 0.2)
> M <- mesh(x, y, z)
> R <- with (M, sqrt(x^2 + y^2 + z^2))
> p <- sin(2*R) /(R+1e-3)
> slice3D(x, y, z, colvar = p, d = 2, theta = 60, border = "black", xs = c(-4, 0), ys = c(-4, 0, 4), zs = c(-4, 0))
geofacet
library(ggplot2)
library(geofacet)
ggplot(eu_imm, aes(year, persons)) +
+ geom_line() +
+ facet_geo(~ name, grid = "eu_grid1") +
+ scale_x_continuous(labels = function(x) paste0("'", substr(x, 3, 4))) +
+ scale_y_sqrt(minor_breaks = NULL) +
+ ylab("# Resettled Persons") +
+ theme_bw()
time series forecasting
# Load packages
library(forecast) # Most popular forecasting pkg
library(sweep) # Broom tidiers for forecast pkg
library(timekit) # Working with time series in R
library(tidyquant) # Get's data from FRED, loads tidyverse behind the scenes
library(geofacet)
> ne_gdp <- tq_get("NENGSP", get = "economic.data", from = "2007-01-01", to = "2017-06-01") %>%
+ rename(gdp = price)
> states <- tibble(abbreviation = state.abb) %>%
+ mutate(fred_code = paste0(abbreviation, "NGSP")) %>%
+ select(2:1)
> states_gdp <- states %>%
+ tq_get(get = "economic.data", from = "2007-01-01", to = "2017-06-01")
>
> # Group and rename
> states_gdp <- states_gdp %>%
+ select(-fred_code) %>%
+ group_by(abbreviation) %>%
+ rename(gdp = price)
> ne_gdp_ts <- ne_gdp %>%
+ tk_ts(start = 2017, freq = 1, silent = TRUE)
> ne_fit_arima <- auto.arima(ne_gdp_ts)
> sw_glance(ne_fit_arima)
# A tibble: 1 x 12
model.desc sigma logLik AIC BIC
<chr> <dbl> <dbl> <dbl> <dbl>
1 ARIMA(0,1,0) with drift 2149.529 -81.29672 166.5934 166.9879
# ... with 7 more variables: ME <dbl>, RMSE <dbl>, MAE <dbl>,
# MPE <dbl>, MAPE <dbl>, MASE <dbl>, ACF1 <dbl>
> ne_fcast <- forecast(ne_fit_arima, h = 3)
> ne_sweep <- sw_sweep(ne_fcast, timekit_idx = TRUE, rename_index = "date")
> ne_sweep
# A tibble: 13 x 7
date key gdp lo.80 lo.95 hi.80 hi.95
<date> <chr> <dbl> <dbl> <dbl> <dbl> <dbl>
1 2007-01-01 actual 81926.0 NA NA NA NA
2 2008-01-01 actual 84873.0 NA NA NA NA
3 2009-01-01 actual 86961.0 NA NA NA NA
4 2010-01-01 actual 92231.0 NA NA NA NA
5 2011-01-01 actual 99935.0 NA NA NA NA
6 2012-01-01 actual 101973.0 NA NA NA NA
7 2013-01-01 actual 106765.0 NA NA NA NA
8 2014-01-01 actual 112087.0 NA NA NA NA
9 2015-01-01 actual 113458.0 NA NA NA NA
10 2016-01-01 actual 115345.0 NA NA NA NA
11 2017-01-01 forecast 119058.2 116303.5 114845.2 121813.0 123271.2
12 2018-01-01 forecast 122771.4 118875.7 116813.4 126667.2 128729.5
13 2019-01-01 forecast 126484.7 121713.3 119187.5 131256.0 133781.8
> ne_sweep %>%
+ ggplot(aes(x = date, y = gdp, color = key)) +
+ # Prediction intervals
+ geom_ribbon(aes(ymin = lo.95, ymax = hi.95),
+ fill = "#D5DBFF", color = NA, size = 0) +
+ geom_ribbon(aes(ymin = lo.80, ymax = hi.80, fill = key),
+ fill = "#596DD5", color = NA, size = 0, alpha = 0.8) +
+ # Actual & Forecast
+ geom_line(size = 1) +
+ geom_point(size = 2) +
+ # Aesthetics
+ theme_tq(base_size = 16) +
+ scale_color_tq() +
+ labs(title = " by Volkan OBAN using R : forecast-sweep-geofacet-timelit-tidyquant packages \n Nebraska GDP, 3-Year Forecast", x = "", y = "GDP, USD Millions")
> states_gdp <- states_gdp %>%
+ nest()
> states_gdp
# A tibble: 50 x 2
abbreviation data
<chr> <list>
1 AL <tibble [10 x 2]>
2 AK <tibble [10 x 2]>
3 AZ <tibble [10 x 2]>
4 AR <tibble [10 x 2]>
5 CA <tibble [10 x 2]>
6 CO <tibble [10 x 2]>
7 CT <tibble [10 x 2]>
8 DE <tibble [10 x 2]>
9 FL <tibble [10 x 2]>
10 GA <tibble [10 x 2]>
# ... with 40 more rows
> states_gdp <- states_gdp %>%
+ mutate(data_ts = map(data, tk_ts, freq = 1, start = 2007, silent = TRUE))
> states_gdp
# A tibble: 50 x 3
abbreviation data data_ts
<chr> <list> <list>
1 AL <tibble [10 x 2]> <S3: ts>
2 AK <tibble [10 x 2]> <S3: ts>
3 AZ <tibble [10 x 2]> <S3: ts>
4 AR <tibble [10 x 2]> <S3: ts>
5 CA <tibble [10 x 2]> <S3: ts>
6 CO <tibble [10 x 2]> <S3: ts>
7 CT <tibble [10 x 2]> <S3: ts>
8 DE <tibble [10 x 2]> <S3: ts>
9 FL <tibble [10 x 2]> <S3: ts>
10 GA <tibble [10 x 2]> <S3: ts>
# ... with 40 more rows
> states_gdp <- states_gdp %>%
+ mutate(fit = map(data_ts, auto.arima))
> states_gdp
# A tibble: 50 x 4
abbreviation data data_ts fit
<chr> <list> <list> <list>
1 AL <tibble [10 x 2]> <S3: ts> <S3: ARIMA>
2 AK <tibble [10 x 2]> <S3: ts> <S3: ARIMA>
3 AZ <tibble [10 x 2]> <S3: ts> <S3: ARIMA>
4 AR <tibble [10 x 2]> <S3: ts> <S3: ARIMA>
5 CA <tibble [10 x 2]> <S3: ts> <S3: ARIMA>
6 CO <tibble [10 x 2]> <S3: ts> <S3: ARIMA>
7 CT <tibble [10 x 2]> <S3: ts> <S3: ARIMA>
8 DE <tibble [10 x 2]> <S3: ts> <S3: ARIMA>
9 FL <tibble [10 x 2]> <S3: ts> <S3: ARIMA>
10 GA <tibble [10 x 2]> <S3: ts> <S3: ARIMA>
# ... with 40 more rows
> states_gdp %>%
+ mutate(glance = map(fit, sw_glance)) %>%
+ unnest(glance, .drop = T)
# A tibble: 50 x 13
abbreviation model.desc sigma logLik
<chr> <chr> <dbl> <dbl>
1 AL ARIMA(0,1,0) with drift 3267.828 -85.06590
2 AK ARIMA(0,0,0) with non-zero mean 4199.313 -97.08934
3 AZ ARIMA(0,2,0) 7559.654 -82.79488
4 AR ARIMA(0,1,0) with drift 2231.839 -81.63464
5 CA ARIMA(0,2,0) 60035.965 -99.37208
6 CO ARIMA(0,1,0) with drift 7064.218 -92.00497
7 CT ARIMA(0,2,0) 5009.932 -79.50274
8 DE ARIMA(0,1,0) with drift 1865.871 -80.02328
9 FL ARIMA(0,2,0) 17001.163 -89.27758
10 GA ARIMA(0,2,0) 6369.686 -81.42147
# ... with 40 more rows, and 9 more variables: AIC <dbl>,
# BIC <dbl>, ME <dbl>, RMSE <dbl>, MAE <dbl>, MPE <dbl>,
# MAPE <dbl>, MASE <dbl>, ACF1 <dbl>
> states_gdp <- states_gdp %>%
+ mutate(forecast = map(fit, forecast, h = 3))
> states_gdp
# A tibble: 50 x 5
abbreviation data data_ts fit
<chr> <list> <list> <list>
1 AL <tibble [10 x 2]> <S3: ts> <S3: ARIMA>
2 AK <tibble [10 x 2]> <S3: ts> <S3: ARIMA>
3 AZ <tibble [10 x 2]> <S3: ts> <S3: ARIMA>
4 AR <tibble [10 x 2]> <S3: ts> <S3: ARIMA>
5 CA <tibble [10 x 2]> <S3: ts> <S3: ARIMA>
6 CO <tibble [10 x 2]> <S3: ts> <S3: ARIMA>
7 CT <tibble [10 x 2]> <S3: ts> <S3: ARIMA>
8 DE <tibble [10 x 2]> <S3: ts> <S3: ARIMA>
9 FL <tibble [10 x 2]> <S3: ts> <S3: ARIMA>
10 GA <tibble [10 x 2]> <S3: ts> <S3: ARIMA>
# ... with 40 more rows, and 1 more variables: forecast <list>
> states_gdp_sweep <- states_gdp %>%
+ mutate(sweep = map(forecast, sw_sweep, timekit_idx = T, rename_index = "date")) %>%
+ select(abbreviation, sweep) %>%
+ unnest()
> states_gdp_sweep
# A tibble: 650 x 8
abbreviation date key gdp lo.80 lo.95 hi.80 hi.95
<chr> <date> <chr> <dbl> <dbl> <dbl> <dbl> <dbl>
1 AL 2007-01-01 actual 169923 NA NA NA NA
2 AL 2008-01-01 actual 172646 NA NA NA NA
3 AL 2009-01-01 actual 168315 NA NA NA NA
4 AL 2010-01-01 actual 174710 NA NA NA NA
5 AL 2011-01-01 actual 180665 NA NA NA NA
6 AL 2012-01-01 actual 185878 NA NA NA NA
7 AL 2013-01-01 actual 190319 NA NA NA NA
8 AL 2014-01-01 actual 194404 NA NA NA NA
9 AL 2015-01-01 actual 199980 NA NA NA NA
10 AL 2016-01-01 actual 204861 NA NA NA NA
# ... with 640 more rows
> states_gdp_sweep %>%
+ ggplot(aes(x = date, y = gdp, color = key)) +
+ # Prediction intervals
+ geom_ribbon(aes(ymin = lo.95, ymax = hi.95),
+ fill = "#D5DBFF", color = NA, size = 0) +
+ geom_ribbon(aes(ymin = lo.80, ymax = hi.80, fill = key),
+ fill = "#596DD5", color = NA, size = 0, alpha = 0.8) +
+ # Actual & Forecast
+ geom_line() +
+ # Aesthetics
+ scale_y_continuous(label = function(x) x*1e-6) +
+ scale_x_date(date_breaks = "5 years", labels = scales::date_format("%Y")) +
+ facet_geo(~ abbreviation, scale = "free_y") +
+ theme_tq() +
+ scale_color_tq() +
+ theme(legend.position = "none",
+ axis.text.x = element_text(angle = 45, hjust = 1),
+ axis.text.y = element_blank()
+ ) +
+ ggtitle(" State GDP, 3-Year Forecast") +
+ xlab("") +
+ ylab("GDP, Free Scale")
> states_gdp_sweep %>%
+ ggplot(aes(x = date, y = gdp, color = key)) +
+ # Prediction intervals
+ geom_ribbon(aes(ymin = lo.95, ymax = hi.95),
+ fill = "#D5DBFF", color = NA, size = 0) +
+ geom_ribbon(aes(ymin = lo.80, ymax = hi.80, fill = key),
+ fill = "#596DD5", color = NA, size = 0, alpha = 0.8) +
+ # Actual & Forecast
+ geom_line() +
+ # Aesthetics
+ scale_y_continuous(label = function(x) x*1e-6) +
+ scale_x_date(date_breaks = "5 years", labels = scales::date_format("%Y")) +
+ facet_geo(~ abbreviation, scale = "free_y") +
+ theme_tq() +
+ scale_color_tq() +
+ theme(legend.position = "none",
+ axis.text.x = element_text(angle = 45, hjust = 1),
+ axis.text.y = element_blank()
+ ) +
+ ggtitle(" by Volkan OBAN using R :TIME SERIES FORECASTING - forecast-sweep-geofacet-timelit-tidyquant packages \n State GDP, 3-Year Forecast") +
+ xlab("") +
+ ylab("GDP, Free Scale")
> states_gdp_sweep %>%
+ ggplot(aes(x = date, y = gdp, color = key)) +
+ # Prediction intervals
+ geom_ribbon(aes(ymin = lo.95, ymax = hi.95),
+ fill = "#D5DBFF", color = NA, size = 0) +
+ geom_ribbon(aes(ymin = lo.80, ymax = hi.80, fill = key),
+ fill = "#596DD5", color = NA, size = 0, alpha = 0.8) +
+ # Actual & Forecast
+ geom_line() +
+ # Aesthetics
+ scale_y_continuous(label = function(x) x*1e-6) +
+ scale_x_date(date_breaks = "5 years", labels = scales::date_format("%Y")) +
+ facet_geo(~ abbreviation, scale = "free_y") +
+ theme_tq() +
+ scale_color_tq() +
+ theme(legend.position = "none",
+ axis.text.x = element_text(angle = 45, hjust = 1),
+ axis.text.y = element_blank()
+ ) +
+ ggtitle(" State GDP, 3-Year Forecast") +
+ xlab("") +
+ ylab("GDP, Free Scale")
> states_gdp_sweep %>%
+ ggplot(aes(x = date, y = gdp, color = key)) +
+ # Prediction intervals
+ geom_ribbon(aes(ymin = lo.95, ymax = hi.95),
+ fill = "#D5DBFF", color = NA, size = 0) +
+ geom_ribbon(aes(ymin = lo.80, ymax = hi.80, fill = key),
+ fill = "#596DD5", color = NA, size = 0, alpha = 0.8) +
+ # Actual & Forecast
+ geom_line() +
+ # Aesthetics
+ scale_y_continuous(label = function(x) x*1e-6) +
+ scale_x_date(date_breaks = "5 years", labels = scales::date_format("%Y")) +
+ facet_geo(~ abbreviation, scale = "free_y") +
+ theme_tq() +
+ scale_color_tq() +
+ theme(legend.position = "none",
+ axis.text.x = element_text(angle = 45, hjust = 1),
+ axis.text.y = element_blank()
+ ) +
+ ggtitle(" State GDP, 3-Year Forecast") +
+ xlab("") +
+ ylab("GDP, Free Scale")
rms package
plot.xmean.ordinaly
rms package - nomogram
w <- upData(d,
cens = 15 * runif(n),
h = .02 * exp(.04 * (age - 50) + .8 * (sex == 'Female')),
d.time = -log(runif(n)) / h,
death = ifelse(d.time <= cens, 1, 0),
d.time = pmin(d.time, cens))
f <- psm(Surv(d.time,death) ~ sex * age, data=w, dist='lognormal')
med <- Quantile(f)
surv <- Survival(f) # This would also work if f was from cph
plot(nomogram(f, fun=function(x) med(lp=x), funlabel="Median Survival Time"))
rms package
> n <- 1000 # define sample size
> set.seed(17) # so can reproduce the results
> age <- rnorm(n, 50, 10)
> blood.pressure <- rnorm(n, 120, 15)
> cholesterol <- rnorm(n, 200, 25)
> sex <- factor(sample(c('female','male'), n,TRUE))
> label(age) <- 'Age' # label is in Hmisc
> label(cholesterol) <- 'Total Cholesterol'
> label(blood.pressure) <- 'Systolic Blood Pressure'
> label(sex) <- 'Sex'
> units(cholesterol) <- 'mg/dl' # uses units.default in Hmisc
> units(blood.pressure) <- 'mmHg'
> # Specify population model for log odds that Y=1
> L <- .4*(sex=='male') + .045*(age-50) +
+ (log(cholesterol - 10)-5.2)*(-2*(sex=='female') + 2*(sex=='male'))
> # Simulate binary y to have Prob(y=1) = 1/[1+exp(-L)]
> y <- ifelse(runif(n) < plogis(L), 1, 0)
> ddist <- datadist(age, blood.pressure, cholesterol, sex)
> options(datadist='ddist')
> fit <- lrm(y ~ blood.pressure + sex * (age + rcs(cholesterol,4)),
+ x=TRUE, y=TRUE)
> p <- Predict(fit, age, cholesterol, sex, np=50) # vary sex last
> bplot(p, main="by Volkan OBAN using R - rms package")
> bplot(p,, main="by Volkan OBAN using R - rms package", lfun=wireframe)
quandl package
plot(stl(Quandl("WIKI/GOOG",type="ts",collapse="monthly")[,11],s.window="per"))
Doodling
doodle <- function(
start=c(0,0),
targets = rbind(c(0,10),c(10,10), c(10,0), c(0,0)) ,
tdist = .25,
speed = c(0,0),
accel = .1,
resis = .005,
jitter = .0005,
chncStp = 0) {
# start - We start with the starting position
# targ - Points that will be pursued (initially just a square)
# tdist - How close we need to get to each point before moving on
# speed - Initial speed
# accel - How fast does the drawer accelerate towards that point
# resis - What percentage of speed is lost each round
# jitter - A normal draw random jitter that moves the writing tool in an unexpected direction.
# chncStp - There is some chance that the drawing tool will kill all momentum and stop.
# First off I define a function uvect to convert any two sets of points
# into a unit vector and measure the distance between the two points.
uvect <- function(p1,p2=NULL) {
if (is.null(p2)) {
p2 <- p1[[2]]
p1 <- p1[[1]]
}
list(vect=(p2-p1)/sqrt(sum((p1-p2)^2)), dist=sqrt(sum((p1-p2)^2)))
}
# Starup parameters
i <- 1
plist <- position <- start # plist saves all of the points that the drawing tool has passed through
vect <- uvect(position,targets[i,])
while(i<=nrow(targets)) {
# Calculate the appropriate unit vector and distance from end point
vect <- uvect(position,targets[i,])
# Remove some amount of speed from previous velocity
speed <- speed*(1-resis)
# IF drawer randomly stops remove all speed
if (rbinom(1,1,chncStp)) speed<-0
#
speed <- speed + accel*vect[[1]] + rnorm(2)*jitter
position <- position + speed
plist <- rbind(plist,position)
vect <- uvect(position,targets[i,])
if (vect[[2]]<tdist) i <- i+1
}
plist
}
plist <- doodle()
shape <- doodle(cbind(c(0,-2,10,15,5,0),c(5,12,10,9,2,0)),resis=.2)
>
> plot(shape, type="l",lwd=1)
>
tidygraph
plot(play_forestfire(40, 0.8))
persp-- Perspective Plots
> x.coord <- seq(-10, 10, length= 50)
> y.coord <- x.coord
> func <- function(x,y) { r <- sqrt(abs(x^3)+y^2); sin(r)/r }
> z.coord <- outer(x.coord, y.coord, func)
> persp(x.coord,y.coord,z.coord,theta=30,phi=30,expand=0.5,col="hotpink4",
+ ltheta=120,shade=0.75,ticktype="detailed",xlab="X",ylab="Y",zlab="Z")
Plot
> data("EuStockMarkets")
> dax <- EuStockMarkets[, 1]
> plot(dax, ylim = c(0, 6000), axes = FALSE)
> axis(1)
> axis(2, las = 1)
> par(new = TRUE)
> plot(diff(log(dax)), ylim = c(-0.1, 0.9), axes = FALSE, col = 2, ylab = "")
> box()
> axis(4, col = 2, col.axis = 2, las = 1)
persp-- Perspective Plots
> y <- x <- seq(-3,3,length=50)
> f <- function(x,y){
+ dnorm(x^4)*dnorm(y^2)}
> z <- outer(x,y,f)
> persp(x,y,z, theta = 60, phi = 30,col = "lightpink1",zlim=c(0,0.2))
persp-- Perspective Plots
> cone <- function(x, y){
+ sqrt(x^4+y^4)
+ }
> x <- y <- seq(-1, 1, length= 20)
> z <- outer(x, y, cone)
> persp(x, y, z)
treemap-- d3treeR
library(treemap)
library(d3treeR)
# dataset
group=c(rep("group-1",4),rep("group-2",2),rep("group-3",3))
subgroup=paste("subgroup" , c(1,2,3,4,1,2,1,2,3), sep="-")
value=c(13,5,22,12,11,7,3,1,23)
data=data.frame(group,subgroup,value)
# basic treemap
p=treemap(data,
index=c("group","subgroup"),
vSize="value",
type="index"
)
# make it interactive ("rootname" becomes the title of the plot):
inter=d3tree2( p , rootname = "General" )
cartography package
library(cartography)
# Upload data attached with the package.
data(nuts2006)
# Now we have a spdf file (shape file) called nuts2.spdf with shape of european regions. We can plot it with the plot function.
summary(nuts2.spdf)
# We also have a dataframe with information concerning every region.
head(nuts2.df)
# Both object have a first column "id" that makes the link between them.
# Create a grid
mygrid <- getGridLayer(spdf = nuts2.spdf, cellsize = 2e+05)
# You can plot the grid
# plot(mygrid$spdf)
# Adapt grid to a numerical variable
datagrid.df <- getGridData(x = mygrid, df = nuts2.df, var = "pop2008")
datagrid.df$densitykm <- datagrid.df$pop2008_density * 1000 * 1000
# Plot background
plot(nuts0.spdf, border = NA, col = NA, bg = "#A6CAE0")
plot(world.spdf, col = "#E3DEBF", border = NA, add = TRUE)
# Plot density of population
choroLayer(spdf = mygrid$spdf, df = datagrid.df, var = "densitykm",
border = "grey80", col = carto.pal(pal1 = "wine.pal", n1 = 6),
legend.pos = "topright", method = "q6",
add = TRUE, legend.title.txt = "Population Density\n(inhabitant/km²)")
# Title, legend..
layoutLayer(title = "Population Density", coltitle = "black",
col = NA, sources = "Eurostat, 2011", scale = NULL,
author = "cartography", frame = FALSE)
igraph
g <- barabasi.game(5000, power=1)
> layout <- layout.fruchterman.reingold(g)
> membership <- cut_at(eb, no = 10)
> plot(g,
+ vertex.color= rainbow(10, .8, .8, alpha=.8)[membership],
+ vertex.size=5, layout=layout, vertex.label=NA,
+ edge.arrow.size=.2)
> eb <- walktrap.community(g)
> membership <- cut_at(eb, no = 10)
> plot(g,
+ vertex.color= rainbow(10, .8, .8, alpha=.8)[membership],
+ vertex.size=5, layout=layout, vertex.label=NA,
+ edge.arrow.size=.2)
igraph
g <- barabasi.game(10000, power=1)
> layout <- layout.fruchterman.reingold(g)
> plot(g, layout=layout, vertex.size=2, vertex.label=NA, edge.arrow.size=.2)
wireframe
wireframe(z ~ x * y, data = g, groups = gr,
scales = list(arrows = FALSE,
x = list(at = c(2, 5, 10)),
y = list(at = c(6, 10, 14),
lab = c('A', 'BBB', 'CCCCC'))
))
lattice package
> g <- expand.grid(x = 1:50, y = 5:25, gr = 1:5)
> g$z <- log((g$x^g$gr + g$y^2) * g$gr)
> wireframe(z ~ x * y, data = g, groups = gr,
+ scales = list(arrows = FALSE),
+ drape = TRUE, colorkey = TRUE,main="by Volkan OBAN using R - lattice package",
+ screen = list(z = 30, x = -60))
Plot
> U = numeric(1000);
> n = 100;
> average = numeric(n);
> for (i in 1 : n)
+ {U = runif(1000);
+ X = tan(pi ∗ (U − 0.5));
+ average[i] = mean(X); }
> plot(1 : n, average[1 : n], type = "l", lwd = 2, col = "red",main="by Volkan OBAN using R") + theme_solarized(light = FALSE) +
+ scale_colour_solarized("red")
mandelbrot package
> par(mfrow = c(1, 2), pty = "s", mar = rep(0, 4))
> plot(mb,col = cols, transform = "inverse")
> plot(mb, col = cols, transform = "log")
ref:https://github.com/blmoore/
mandelbrot package
> library(ggplot2)
>
> mb <- mandelbrot(xlim = c(-0.8335, -0.8325),
+ ylim = c(0.205, 0.206),
+ resolution = 1200L,
+ iterations = 1000)
>
>
> cols <- c(
+ colorRampPalette(c("#e7f0fa", "#c9e2f6", "#95cbee",
+ "#0099dc", "#4ab04a", "#ffd73e"))(10),
+ colorRampPalette(c("#eec73a", "#e29421", "#e29421",
+ "#f05336","#ce472e"), bias=2)(90),
+ "black")
>
> df <- as.data.frame(mb)
> ggplot(df, aes(x = x, y = y, fill = value)) +
+ geom_raster(interpolate = TRUE) + theme_void() +
+ scale_fill_gradientn(colours = cols, guide = "none") + ggtitle("by Volkan OBAN using R-mandelbrot package ")
> library(ggplot2)
>
> mb <- mandelbrot(xlim = c(-0.8335, -0.8325),
+ ylim = c(0.205, 0.206),
+ resolution = 1200L,
+ iterations = 1000)
>
>
> cols <- c(
+ colorRampPalette(c("#e7f0fa", "#c9e2f6", "#95cbee",
+ "#0099dc", "#4ab04a", "#ffd73e"))(10),
+ colorRampPalette(c("#eec73a", "#e29421", "#e29421",
+ "#f05336","#ce472e"), bias=2)(90),
+ "black")
>
> df <- as.data.frame(mb)
> ggplot(df, aes(x = x, y = y, fill = value)) +
+ geom_raster(interpolate = TRUE) + theme_void() +
+ scale_fill_gradientn(colours = cols, guide = "none")
sde package
t <- 0:100 # time
> sig2 <- 0.01
> nsim <- 1000
> ## we'll simulate the steps from a uniform distribution with limits set to
> ## have the same variance (0.01) as before
> X <- matrix(runif(n = nsim * (length(t) - 1), min = -sqrt(3 * sig2), max = sqrt(3 *
+ sig2)), nsim, length(t) - 1)
> X <- cbind(rep(0, nsim), t(apply(X, 1, cumsum)))
> plot(t, X[1, ], xlab = "time",ylab = "phenotype", ylim = c(-2, 2), type = "l")
> apply(X[2:nsim, ], 1, function(x, t) lines(t, x), t = t)
ggspectra pckg
library(photobiology)
plot(sun.spct) + theme_solarized(light = FALSE) +
+ scale_colour_solarized("red")
ggspectra pckg
library(photobiology)
plot(yellow_gel.spct)
plot(yellow_gel.spct, pc.out = TRUE)
ggraph ggthemes
graph <- graph_from_data_frame(flare$edges, vertices = flare$vertices)
set.seed(1)
ggraph(graph, 'circlepack', weight = 'size') +
geom_node_circle(aes(fill = depth), size = 0.25, n = 50) +
coord_fixed()
> ggraph(graph, 'circlepack', weight = 'size') +
+ geom_node_circle(aes(fill = depth), size = 0.25, n = 50) +
+ coord_fixed() + ggtitle("by Volkan OBAN using R-ggraph ") + theme_economist() + scale_colour_economist() +
+ scale_y_continuous(position = "right")
survminer package
ggsurvplot(
+ fit, # survfit object with calculated statistics.
+ data = lung, # data used to fit survival curves.
+ risk.table = TRUE, # show risk table.
+ pval = TRUE, # show p-value of log-rank test.
+ conf.int = TRUE, # show confidence intervals for
+ # point estimates of survival curves.
+ xlim = c(0,500), # present narrower X axis, but not affect
+ # survival estimates.
+ xlab = "Time in days", # customize X axis label.
+ break.time.by = 100, # break X axis in time intervals by 500.
+ ggtheme = theme_light(), # customize plot and risk table with a theme.
+ risk.table.y.text.col = T, # colour risk table text annotations.
+ risk.table.y.text = FALSE ,title="by Volkan OBAN using R - survminer"
+ )
>
ggTimeSeries
calenda HeatMap
ggmosaic package
ggplot(data = happy) +
+ geom_mosaic(aes(weight = wtssall, x = product(health), fill = health)) +
+ facet_grid(happy~.)
ggmosaic package
ggplot(data = happy) +
+ geom_mosaic(aes(weight=wtssall, x=product(health, sex, degree), fill=happy), na.rm=TRUE)
ggplot2 maps ggthemes
wm <- map("world",fill=TRUE,col=0,xlim=c(-10,40),ylim=c(30,60))
ggplot(wm, aes(long, lat, group = group)) +
+ geom_polygon(fill = "white", colour = "purple") + theme_economist() + scale_colour_economist() +
+ scale_y_continuous(position = "right")
ggplot2 ggalt ggthemes
> library(dplyr)
> library(tidyr)
> library(scales)
> library(ggplot2)
> library(ggalt) # devtools::install_github("hrbrmstr/ggalt")
>
> health <- read.csv("https://rud.is/dl/zhealth.csv", stringsAsFactors=FALSE,
+ header=FALSE, col.names=c("pct", "area_id"))
>
> areas <- read.csv("https://rud.is/dl/zarea_trans.csv", stringsAsFactors=FALSE, header=TRUE)
>
> health %>%
+ mutate(area_id=trunc(area_id)) %>%
+ arrange(area_id, pct) %>%
+ mutate(year=rep(c("2014", "2013"), 26),
+ pct=pct/100) %>%
+ left_join(areas, "area_id") %>%
+ mutate(area_name=factor(area_name, levels=unique(area_name))) -> health
>
> setNames(bind_cols(filter(health, year==2014), filter(health, year==2013))[,c(4,1,5)],
+ c("area_name", "pct_2014", "pct_2013")) -> health
>
> gg <- ggplot(health, aes(x=pct_2014, xend=pct_2013, y=area_name, group=area_name)) + ggtitle("by Volkan OBAN using R ")
> gg <- gg + geom_dumbbell(colour="#a3c4dc", size=1.5, colour_xend="#0e668b",
+ dot_guide=TRUE, dot_guide_size=0.15)
>
> gg
> gg + theme_wsj() + scale_colour_wsj("colors6", "")
> gg + theme_hc(bgcolor = "darkunica") +
+ scale_colour_hc("darkunica")
>
ggstance package
> library("ggstance")
>
> # Horizontal with ggstance
> ggplot(mpg, aes(hwy, class, fill = factor(cyl))) +
+ geom_boxploth()
ggplot2 and ggtech
ref:
http://kbroman.org/datacarpentry_R_2016-06-01/04-ggplot2.html
ggplot2 and ggthemes
ref:
http://kbroman.org/datacarpentry_R_2016-06-01/04-ggplot2.html
ggplot2 and ggthemes
ref:
http://kbroman.org/datacarpentry_R_2016-06-01/04-ggplot2.html
ggplot2 and ggthe
ref:
http://kbroman.org/datacarpentry_R_2016-06-01/04-ggplot2.html
ggplot2
ref:
http://kbroman.org/datacarpentry_R_2016-06-01/04-ggplot2.html
ggplot2 and ggthemes
ref:
http://kbroman.org/datacarpentry_R_2016-06-01/04-ggplot2.html
ggplot2
ref: http://kbroman.org/datacarpentry_R_2016-06-01/04-ggplot2.html
ggplot2
ref http://kbroman.org/datacarpentry_R_2016-06-01/04-ggplot2.html
ggplot2 and ggthemes
a<- ggplot(surveys_complete, aes(x = species_id, y = hindfoot_length)) + geom_boxplot()
a + theme_economist() + scale_colour_economist() +
+ scale_y_continuous(position = "right"
epanetReader package-- plotSparklineTable
> plotSparklineTable(Theoph, row.var = 'Subject', col.vars = 'conc')
epanetReader package-- plotSparklineTable
> msr <- file.path( find.package("epanetReader"), "extdata","example.rpt")
> #read the results into R
> x <- read.msxrpt(msr)
> names(x)
[1] "Title" "nodeResults" "linkResults"
> summary(x)
plot(x)
sjplot--sjp.glm: plot probability curves (relationship between predictors and response)
> mydf <- data.frame(y = as.factor(y),
+ sex = to_factor(efc$c161sex),
+ dep = to_factor(efc$e42dep),
+ barthel = efc$barthtot,
+ education = to_factor(efc$c172code))
> # fit model
> fit <- glm(y ~., data = mydf, family = binomial(link = "logit"))
# plot probability curves (relationship between predictors and response)
> sjp.glm(fit, title = " Negative impact with 7 items", type = "slope")
sjPlot and sjmisc package
airgrp <- sjc.qclus(airquality)
sjc.qclus(airquality, groupcount = 3, groups = airgrp$classification, title=" new k-means cluster analysis")
ggplot2
a<-ggplot(mtcars, aes(x = mpg^2, y = wt/cyl)) + geom_smooth(fill="purple",color="pink",size=2) + geom_jitter(color="darkgreen",shape=2) + geom_point(color="yellow") + ggtitle("by Volkan OBAN using R ")
a
Plot
> day=as.Date("2017-06-14") - 0:364
> value=runif(365) + seq(-140, 224)^2 / 10000
> data=data.frame(day, value)
> data %>% mutate(month = as.Date(cut(day, breaks = "month"))) %>%
+ ggplot(aes(x=day, y=value, fill=as.factor(month))) +
+ geom_line() +
+ geom_area() +
+ theme(
+ legend.position="none",
+ axis.text.x=element_blank(),
+ axis.ticks.x=element_blank(),
+ strip.background = element_rect(fill=alpha("slateblue",0.2)),
+ strip.placement="bottom"
+ ) +
+ xlab("by Volkan OBAN using R \n faceting for time series") +
+ facet_wrap(~as.Date(month), scales="free", ncol=3) + theme_tufte(ticks=FALSE) +
+ geom_tufteboxplot(median.type = "line", whisker.type = 'line', hoffset = 0, width = 3)
quantmod and plotly
library(plotly)
library(quantmod)
# get data
getSymbols("AAPL",src='yahoo')
df <- data.frame(Date=index(AAPL),coredata(AAPL))
# create Bollinger Bands
bbands <- BBands(AAPL[,c("AAPL.High","AAPL.Low","AAPL.Close")])
# join and subset data
df <- subset(cbind(df, data.frame(bbands[,1:3])), Date >= "2015-02-14")
# colors column for increasing and decreasing
for (i in 1:length(df[,1])) {
if (df$AAPL.Close[i] >= df$AAPL.Open[i]) {
df$direction[i] = 'Increasing'
} else {
df$direction[i] = 'Decreasing'
}
}
i <- list(line = list(color = '#17BECF'))
d <- list(line = list(color = '#7F7F7F'))
# plot candlestick chart
p <- df %>%
plot_ly(x = ~Date, type="candlestick",
open = ~AAPL.Open, close = ~AAPL.Close,
high = ~AAPL.High, low = ~AAPL.Low, name = "AAPL",
increasing = i, decreasing = d) %>%
add_lines(y = ~up , name = "B Bands",
line = list(color = '#ccc', width = 0.5),
legendgroup = "Bollinger Bands",
hoverinfo = "none") %>%
add_lines(y = ~dn, name = "B Bands",
line = list(color = '#ccc', width = 0.5),
legendgroup = "Bollinger Bands",
showlegend = FALSE, hoverinfo = "none") %>%
add_lines(y = ~mavg, name = "Mv Avg",
line = list(color = '#E377C2', width = 0.5),
hoverinfo = "none") %>%
layout(yaxis = list(title = "Price"))
# plot volume bar chart
pp <- df %>%
plot_ly(x=~Date, y=~AAPL.Volume, type='bar', name = "AAPL Volume",
color = ~direction, colors = c('#17BECF','#7F7F7F')) %>%
layout(yaxis = list(title = "Volume"))
# create rangeselector buttons
rs <- list(visible = TRUE, x = 0.5, y = -0.055,
xanchor = 'center', yref = 'paper',
font = list(size = 9),
buttons = list(
list(count=1,
label='RESET',
step='all'),
list(count=1,
label='1 YR',
step='year',
stepmode='backward'),
list(count=3,
label='3 MO',
step='month',
stepmode='backward'),
list(count=1,
label='1 MO',
step='month',
stepmode='backward')
))
# subplot with shared x axis
p <- subplot(p, pp, heights = c(0.7,0.2), nrows=2,
shareX = TRUE, titleY = TRUE) %>%
layout(title = paste("Apple: 2015-02-14 -",Sys.Date()),
xaxis = list(rangeselector = rs),
legend = list(orientation = 'h', x = 0.5, y = 1,
xanchor = 'center', yref = 'paper',
font = list(size = 10),
bgcolor = 'transparent'))
quantmod and plotly
library(plotly)
library(quantmod)
getSymbols("AAPL",src='yahoo')
df <- data.frame(Date=index(AAPL),coredata(AAPL))
# annotation
a <- list(text = "Stock Split",
x = '2014-06-06',
y = 1.02,
xref = 'x',
yref = 'paper',
xanchor = 'left',
showarrow = FALSE
)
# use shapes to create a line
l <- list(type = line,
x0 = '2014-06-06',
x1 = '2014-06-06',
y0 = 0,
y1 = 1,
xref = 'x',
yref = 'paper',
line = list(color = 'black',
width = 0.5)
)
p <- df %>%
plot_ly(x = ~Date, type="candlestick",
open = ~AAPL.Open, close = ~AAPL.Close,
high = ~AAPL.High, low = ~AAPL.Low) %>%
layout(title = "Apple Stock",
annotations = a,
shapes = l)
quantmod
getSymbols("AAPL")
chartSeries(AAPL)
title(" quantmod ", sub = "",
cex.main = 1, font.main= 2, col.main= "green",
cex.sub = 0.75, font.sub =1, col.sub = "red")
GGally
a<- ggpairs(iris)
a
psych package
pairs.panels(iris[1:4],bg=c("red","purple","blue")[iris$Species],pch=21,main=" Fisher Iris data by Species",hist.col="purple")
igraph
Show in New WindowClear OutputExpand/Collapse Output
shiny.tag
shiny.tag
shiny.tag
shiny.tag
shiny.tag
shiny.tag
shiny.tag
shiny.tag
Show in New WindowClear OutputExpand/Collapse Output
Error: unexpected symbol in:
"
print(p)Show"
Modify Chunk OptionsRun All Chunks AboveRun Current ChunkModify Chunk OptionsRun All Chunks AboveRun Current ChunkModify Chunk OptionsRun All Chunks AboveRun Current Chunk
Console~/
> library(miniCRAN)
> library(igraph)
>
>
> pk <- c("igraph","agop","bc3net","BDgraph","c3net","camel",
+ "cccd", "CDVine", "CePa", "CINOEDV", "cooptrees","corclass", "cvxclustr", "dcGOR",
+ "ddepn","dils", "dnet", "dpa", "ebdbNet", "editrules",
+ "fanovaGraph", "fastclime", "FisHiCal",
+ "flare", "G1DBN", "gdistance", "GeneNet", "GeneReg", "genlasso", "ggm", "gRapfa", "hglasso",
+ "huge", "igraphtosonia", "InteractiveIGraph", "iRefR", "JGL", "lcd", "linkcomm", "locits",
+ "loe", "micropan", "mlDNA", "mRMRe", "nets", "netweavers", "optrees", "packdep", "PAGI",
+ "pathClass", "PBC", "phyloTop", "picasso", "PoMoS", "popgraph", "PROFANCY", "qtlnet", "RCA",
+ "ReliabilityTheory", "rEMM", "restlos", "rgexf", "RNetLogo", "ror", "RWBP", "sand", "SEMID",
+ "shp2graph", "SINGLE", "spacejam", "TDA", "timeordered", "tnet")
>
>
> dg <- makeDepGraph(pk)
> plot(dg,main=" Network of reverse depends for igraph",cex=.4,vertex.size=8)
Plot
> require(graphics)
>
> fr <- function(x) { ## Rosenbrock Banana function
+ x1 <- x[1]
+ x2 <- x[2]
+ 100 * (x2 - x1 * x1)^2 + (1 - x1)^2
+ }
> grr <- function(x) { ## Gradient of 'fr'
+ x1 <- x[1]
+ x2 <- x[2]
+ c(-400 * x1 * (x2 - x1 * x1) - 2 * (1 - x1),
+ 200 * (x2 - x1 * x1))
+ }
> optim(c(-1.2,1), fr)
> (res <- optim(c(-1.2,1), fr, grr, method = "BFGS"))
> optimHess(res$par, fr, grr)
> optim(c(-1.2,1), fr, NULL, method = "BFGS", hessian = TRUE)
> ## These do not converge in the default number of steps
> optim(c(-1.2,1), fr, grr, method = "CG")
> optim(c(-1.2,1), fr, grr, method = "CG", control = list(type = 2))
> optim(c(-1.2,1), fr, grr, method = "L-BFGS-B")
>
> flb <- function(x)
+ { p <- length(x); sum(c(1, rep(4, p-1)) * (x - c(1, x[-p])^2)^2) }
> ## 25-dimensional box constrained
> optim(rep(3, 25), flb, NULL, method = "L-BFGS-B",
+ lower = rep(2, 25), upper = rep(4, 25)) # par[24] is *not* at boundary
>
> ## "wild" function , global minimum at about -15.81515
> fw <- function (x)
+ 10*sin(0.3*x)*sin(1.3*x^2) + 0.00001*x^4 + 0.2*x+80
> plot(fw, -50, 50, n = 1000, main = "optim() minimising 'wild function'")
>
> res <- optim(50, fw, method = "SANN",
+ control = list(maxit = 20000, temp = 20, parscale = 20))
> res
> ## Now improve locally {typically only by a small bit}:
> (r2 <- optim(res$par, fw, method = "BFGS"))
> points(r2$par, r2$value, pch = 8, col = "red", cex = 2)
>
> ## Combinatorial optimization: Traveling salesman problem
> library(stats) # normally loaded
>
> eurodistmat <- as.matrix(eurodist)
>
> distance <- function(sq) { # Target function
+ sq2 <- embed(sq, 2)
+ sum(eurodistmat[cbind(sq2[,2], sq2[,1])])
+ }
>
> genseq <- function(sq) { # Generate new candidate sequence
+ idx <- seq(2, NROW(eurodistmat)-1)
+ changepoints <- sample(idx, size = 2, replace = FALSE)
+ tmp <- sq[changepoints[1]]
+ sq[changepoints[1]] <- sq[changepoints[2]]
+ sq[changepoints[2]] <- tmp
+ sq
+ }
>
> sq <- c(1:nrow(eurodistmat), 1) # Initial sequence: alphabetic
> distance(sq)
[1] 29625
> # rotate for conventional orientation
> loc <- -cmdscale(eurodist, add = TRUE)$points
> x <- loc[,1]; y <- loc[,2]
> s <- seq_len(nrow(eurodistmat))
> tspinit <- loc[sq,]
>
> plot(x, y, type = "n", asp = 1, xlab = "", ylab = "",
+ main = "prepared by Volkan OBAN using R stats package
+ optim \n initial solution of traveling salesman problem", axes = FALSE)
> arrows(tspinit[s,1], tspinit[s,2], tspinit[s+1,1], tspinit[s+1,2],
+ angle = 10, col = "green")
> text(x, y, labels(eurodist), cex = 0.8)
>
> set.seed(123) # chosen to get a good soln relatively quickly
> res <- optim(sq, distance, genseq, method = "SANN",
+ control = list(maxit = 30000, temp = 2000, trace = TRUE,
+ REPORT = 500))
> tspres <- loc[res$par,]
> plot(x, y, type = "n", asp = 1, xlab = "", ylab = "",
+ main = "prepared by Volkan OBAN using R stats package optim \n optim() 'solving' traveling salesman problem", axes = FALSE)
> arrows(tspres[s,1], tspres[s,2], tspres[s+1,1], tspres[s+1,2],
+ angle = 10, col = "red")
> text(x, y, labels(eurodist), cex = 0.8)
>
ggfortify
http://www.sthda.com/english/wiki/ggfortify-extension-to-ggplot2-to-handle-some-popular-packages-r-software-and-data-visualization
ggfortify
http://www.sthda.com/english/wiki/ggfortify-extension-to-ggplot2-to-handle-some-popular-packages-r-software-and-data-visualization
sunshine
> par(mar=c(0,0,0,0))
> pie(abs(rnorm(150)) , radius=10 , border="transparent" , xlim=c(0,5) )
latticeExtra package
> xyplot(stl(log(co2), s.window=21),
+ main = "STL decomposition of CO2 data")
ggplot2 - waffle chart
library(ggplot2)
# Here's some data I had lying around
tb <- structure(list(region = c("Africa", "Asia", "Latin America",
"Other", "US-born"), ncases = c(36L, 34L, 56L, 2L, 44L)), .Names = c("region",
"ncases"), row.names = c(NA, -5L), class = "data.frame")
# A bar chart of counts
ggplot(tb, aes(x = region, weight = ncases, fill = region)) +
geom_bar()
# Bar chart of percentages
ggplot(tb, aes(x = region, weight = ncases/sum(ncases), fill = region)) +
geom_bar() +
scale_y_continuous(formatter = 'percent')
# Pie chart equivalents. Forgive me, Hadley, for I must sin.
ggplot(tb, aes(x = factor(1), weight = ncases, fill = region)) +
geom_bar(width = 1) +
coord_polar(theta = "y") +
labs(x = "", y = "")
ggplot(tb, aes(x = factor(1), weight = ncases/sum(ncases), fill = region)) +
geom_bar() +
scale_y_continuous(formatter = 'percent') +
coord_polar(theta = "y") +
labs(x = "", y = "")
# Waffles
# How many rows do you want the y axis?
ndeep <- 5
# I need to convert my data into a data.frame with a unique specified x
# and y axis for each case
# Note - it's actually important to specify y first for a
# horizontally-accumulating waffle
tb4waffles <- expand.grid(y = 1:ndeep,
x = seq_len(ceiling(sum(tb$ncases) / ndeep)))
# Expand the counts into a full vector of region labels - i.e., de-aggregate
regionvec <- rep(tb$region, tb$ncases)
# Depending on the value of ndeep, there might be more spots on the x-y grid
# than there are cases - so fill those with NA
tb4waffles$region <- c(regionvec, rep(NA, nrow(tb4waffles) - length(regionvec)))
# Plot it
ggplot(tb4waffles, aes(x = x, y = y, fill = region)) +
geom_tile(color = "white") + # The color of the lines between tiles
scale_fill_manual("Region of Birth",
values = RColorBrewer::brewer.pal(5, "Dark2")) +
opts(title = "TB Cases by Region of Birth")
waffle chart-waffle package
http://harrycaufield.net/severalog/2016/7/29/8jt1lrt7hd2vqh4heu7mcuqrdcg0od
waffle chart
ref. and code: http://harrycaufield.net/severalog/2016/7/29/8jt1lrt7hd2vqh4heu7mcuqrdcg0od
network package
> data(flo)
> nflo<-network(flo)
> #Display the network, indicating degree and flagging the Medicis
> plot(nflo, vertex.cex=apply(flo,2,sum)+1, usearrows=FALSE,vertex.sides=3+apply(flo,2,sum),vertex.col=2+(network.vertex.names(nflo)=="Medici"))
plotly network viz.
> library(plotly)
> library(igraph)
>
> data(karate, package="igraphdata")
> G <- upgrade_graph(karate)
> L <- layout.circle(G)
> vs <- V(G)
> es <- as.data.frame(get.edgelist(G))
>
> Nv <- length(vs)
> Ne <- length(es[1]$V1)
> Xn <- L[,1]
> Yn <- L[,2]
>
> network <- plot_ly(x = ~Xn, y = ~Yn, mode = "markers", text = vs$label, hoverinfo = "text")
> edge_shapes <- list()
> for(i in 1:Ne) {
+ v0 <- es[i,]$V1
+ v1 <- es[i,]$V2
+
+ edge_shape = list(
+ type = "line",
+ line = list(color = "#030303", width = 0.3),
+ x0 = Xn[v0],
+ y0 = Yn[v0],
+ x1 = Xn[v1],
+ y1 = Yn[v1]
+ )
+
+ edge_shapes[[i]] <- edge_shape
+ }
> axis <- list(title = "", showgrid = FALSE, showticklabels = FALSE, zeroline = FALSE)
>
> p <- layout(
+ network,
+ title = 'by Volkan OBAN using R - igraph \n Karate Network',
+ shapes = edge_shapes,
+ xaxis = axis,
+ yaxis = axis
+ )
> p
likert
require(likert)
> data(pisaitems)
>
> ##### Item 24: Reading Attitudes
> items24 <- pisaitems[,substr(names(pisaitems), 1,5) == 'ST24Q']
>
> items24 <- rename(items24, c(
+ ST24Q01="I read only if I have to.",
+ ST24Q02="Reading is one of my favorite hobbies.",
+ ST24Q03="I like talking about books with other people.",
+ ST24Q04="I find it hard to finish books.",
+ ST24Q05="I feel happy if I receive a book as a present.",
+ ST24Q06="For me, reading is a waste of time.",
+ ST24Q07="I enjoy going to a bookstore or a library.",
+ ST24Q08="I read only to get information that I need.",
+ ST24Q09="I cannot sit still and read for more than a few minutes.",
+ ST24Q10="I like to express my opinions about books I have read.",
+ ST24Q11="I like to exchange books with my friends."))
> l24g <- likert(items24[,1:2], grouping=pisaitems$CNT)
> plot(l24g)
heart.
> dat<- data.frame(t=seq(0, 2*pi, by=0.1) )
> xhrt <- function(t) 16*sin(t)^3
> yhrt <- function(t) 13*cos(t)-5*cos(2*t)-2*cos(3*t)-cos(4*t)
> dat$y=yhrt(dat$t)
> dat$x=xhrt(dat$t)
> with(dat, plot(x,y, type="l"))
> with(dat, polygon(x,y, col="darkred"))
BAMMtools package
ixx <- rep(c(10, 30, 40), 2);
plot.new()
par(mfrow=c(2,3));
colschemes <- list();
colschemes[1:3] <- 'temperature'
colschemes[4:6] <- list(c('blue', 'gray', 'red'))
for (i in 1:length(ixx)) {
par(mar=c(0,0,0,0))
index <- ixx[i]
eventsub <- subsetEventData(edata_whales, index=index);
plot.bammdata(eventsub, method='polar', pal= colschemes[[i]], par.reset=FALSE, lwd=3)
addBAMMshifts(eventsub, method='polar', index=1, col='white', bg='black', cex=5, par.reset=FALSE)
}
BAMMtools package
library(BAMMtools)
data(whales, events.whales)
edata_whales <- getEventData(whales, events.whales, burnin=0.1)
plot.bammdata(edata_whales, lwd=3, method="polar", pal="temperature")
data(primates, events.primates)
ed <- getEventData(primates, events.primates, burnin=0.25, type = 'trait')
par(mfrow=c(1,3), mar=c(1, 0.5, 0.5, 0.5), xpd=TRUE)
q <- plot.bammdata(ed, tau=0.001, breaksmethod='linear', lwd=2)
addBAMMshifts(ed, par.reset=FALSE, cex=2)
title(sub='linear',cex.sub=2, line=-1)
addBAMMlegend(q, location=c(0, 1, 140, 220))
q <- plot.bammdata(ed, tau=0.001, breaksmethod='linear', color.interval=c(NA,0.12), lwd=2)
addBAMMshifts(ed, par.reset=FALSE, cex=2)
title(sub='linear - color.interval',cex.sub=2, line=-1)
addBAMMlegend(q, location=c(0, 1, 140, 220))
q <- plot.bammdata(ed, tau=0.001, breaksmethod='jenks', lwd=2)
addBAMMshifts(ed, par.reset=FALSE, cex=2)
title(sub='jenks',cex.sub=2, line=-1)
addBAMMlegend(q, location=c(0, 1, 140, 220))
geomnet ggnetwork
> library(ggnetwork)
> set.seed(10312016)
> ggplot(ggnetwork(em.net, arrow.gap = 0.02, layout = "fruchtermanreingold"),
+ aes(x, y, xend = xend, yend = yend)) +
+ geom_edges(
+ aes(color = curr_empl_type),
+ alpha = 0.25,
+ arrow = arrow(length = unit(5, "pt"),
+ type = "closed"),
+ curvature = 0.05) +
+ geom_nodes(aes(color = curr_empl_type),
+ size = 4) +
+ scale_color_brewer("Employment Type",
+ palette = "Set1") +
+ theme_blank() +
+ theme(legend.position = "bottom")
Plot
library(tidyverse)
library(rvest)
library(magrittr)
library(ggmap)
library(stringr)
ref:https://www.r-bloggers.com/how-to-make-a-global-map-in-r-step-by-step/
heatmap.2
library(gplots)
>
> #Build the matrix data to look like a correlation matrix
> x <- matrix(rnorm(64), nrow=8)
> x <- (x - min(x))/(max(x) - min(x)) #Scale the data to be between 0 and 1
> for (i in 1:8) x[i, i] <- 1.0 #Make the diagonal all 1's
>
> #Format the data for the plot
> xval <- formatC(x, format="f", digits=2)
> pal <- colorRampPalette(c(rgb(0.96,0.96,1), rgb(0.1,0.1,0.9)), space = "rgb")
>
> #Plot the matrix
> x_hm <- heatmap.2(x, Rowv=FALSE, Colv=FALSE, dendrogram="none", main="by Volkan OBAN using R \n 8 X 8 Matrix Using Heatmap.2", xlab="Columns", ylab="Rows", col=pal, tracecol="#303030", trace="none", cellnote=xval, notecol="black", notecex=0.8, keysize = 1.3, margins=c(5, 5))
netdiffudeR package
set.seed(1231)
# Random scale-free diffusion network
x <- rdiffnet(1000, 4, seed.graph="scale-free", seed.p.adopt = .025,
rewire = FALSE, seed.nodes = "central",
rgraph.arg=list(self=FALSE, m=4),
threshold.dist = function(id) runif(1,.2,.4))
# Diffusion map (no random toa)
dm0 <- diffusionMap(x, kde2d.args=list(n=150, h=1), layout=igraph::layout_with_fr)
# Random
diffnet.toa(x) <- sample(x$toa, size = nnodes(x))
# Diffusion map (random toa)
dm1 <- diffusionMap(x, layout = dm0$coords, kde2d.args=list(n=150, h=.5))
oldpar <- par(no.readonly = TRUE)
col <- colorRampPalette(blues9)(100)
par(mfrow=c(1,2), oma=c(1,0,0,0), cex=.8)
image(dm0, col=col, main="Non-random Times of Adoption\nAdoption from the core.")
image(dm1, col=col, main="Random Times of Adoption")
par(mfrow=c(1,1))
mtext("Both networks have the same distribution on times of adoption", 1,
outer = TRUE)
sna package in R
g<-matrix(0,50,50)
g[1,]<-1; g[,1]<-1 #Create a star
gplot(g)
gplot(rewire.ws(g,0.05))
sna package in R
gplot(rgws(1,100,1,2,1))
arulesViz
library(arules)
> rules.all <- apriori(titanic.raw)
> load("titanic.raw.rdata")
> library(arulesViz)
> plot(rules.all)
plot(rules.all,main=" ", method = "graph", control = list(type = "items"))
networks
> net.bg <- sample_pa(80)
>
> V(net.bg)$size <- 8
>
> V(net.bg)$frame.color <- "firebrick3"
>
> V(net.bg)$color <- "hotpink"
>
> V(net.bg)$label <- ""
> l <- layout_in_circle(net.bg)
>
> plot(net.bg)
geomnet -- ggmap
metro_map <- ggmap::get_map(location = c(left = -77.22257, bottom = 39.05721,
right = -77.11271, top = 39.14247))
ggmap::ggmap(metro_map) +
geom_net(data = tripnet, layout.alg = NULL, labelon = TRUE,
vjust = -0.5, ealpha = 0.5,
aes(from_id = from_id,
to_id = to_id,
x = long, y = lat,
linewidth = n / 15,
colour = Metro)) +
scale_colour_manual("Metro Station", values = c("grey40", "darkorange")) +
theme_net() %+replace% theme(aspect.ratio=NULL, legend.position = "bottom") +
coord_map()
ref:https://cran.r-project.org/web/packages/ggCompNet/vignettes/examples-from-paper.html
Plot
> data(bikes, package = 'geomnet')
> # data step for geomnet
> tripnet <- fortify(as.edgedf(bikes$trips), bikes$stations[,c(2,1,3:5)])
> tripnet$Metro = FALSE
> idx <- grep("Metro", tripnet$from_id)
> tripnet$Metro[idx] <- TRUE
>
> # plot the bike sharing network shown in Figure 7b
> set.seed(1232016)
> ggplot(aes(from_id = from_id, to_id = to_id), data = tripnet) +
+ geom_net(aes(linewidth = n / 15, colour = Metro),
+ labelon = TRUE, repel = TRUE) +
+ theme_net() +
+ xlim(c(-0.1, 1.1)) +
+ scale_colour_manual("Metro Station", values = c("grey40", "darkorange")) +
+ theme(legend.position = "bottom")
geomnet and ggplot2
data(football, package = 'geomnet')
rownames(football$vertices) <-
football$vertices$label
# create network
fb.net <- network::network(football$edges[, 1:2],
directed = TRUE)
# create node attribute (what conference is team in?)
fb.net %v% "conf" <-
football$vertices[
network.vertex.names(fb.net), "value"
]
# create edge attribute (between teams in same conference?)
network::set.edge.attribute(
fb.net, "same.conf",
football$edges$same.conf)
set.seed(5232011)
ggnet2(fb.net, mode = "fruchtermanreingold",
color = "conf", palette = "Paired",
color.legend = "Conference",
edge.color = c("color", "grey75"))
---
ftnet <- fortify(as.edgedf(football$edges), football$vertices)
ftnet$schools <- ifelse(
ftnet$value == "Independents", ftnet$from_id, "")
# create data plot
set.seed(5232011)
ggplot(data = ftnet,
aes(from_id = from_id, to_id = to_id)) +
geom_net(layout.alg = 'fruchtermanreingold',
aes(colour = value, group = value,
linetype = factor(same.conf != 1),
label = schools),
linewidth = 0.5,
size = 5, vjust = -0.75, alpha = 0.3) +
theme_net() +
theme(legend.position = "bottom") +
scale_colour_brewer("Conference", palette = "Paired") +
guides(linetype = FALSE)
ggnet and ggplot2
> library(ggnet)
> data(email, package = 'geomnet')
>
> # create node attribute data
> em.cet <- as.character(
+ email$nodes$CurrentEmploymentType)
> names(em.cet) = email$nodes$label
>
> # remove the emails sent to all employees
> edges <- subset(email$edges, nrecipients < 54)
> # create network
> em.net <- edges[, c("From", "to") ]
> em.net <- network::network(em.net, directed = TRUE)
> # create employee type node attribute
> em.net %v% "curr_empl_type" <-
+ em.cet[ network.vertex.names(em.net) ]
> set.seed(10312016)
> ggnet2(em.net, color = "curr_empl_type",
+ size = 4, palette = "Set1",
+ arrow.size = 5, arrow.gap = 0.02,
+ edge.alpha = 0.25, mode = "fruchtermanreingold",
+ edge.color = c("color", "grey50"),
+ color.legend = "Employment Type") + ggtitle("by Volkan OBAN using R - ggnet") +
+ theme(legend.position = "bottom")
> email$edges <- email$edges[, c(1,5,2:4,6:9)]
> emailnet <- fortify(
+ as.edgedf(subset(email$edges, nrecipients < 54)),
+ email$nodes)
> set.seed(10312016)
> ggplot(data = emailnet,
+ aes(from_id = from_id, to_id = to_id)) +
+ geom_net(layout.alg = "fruchtermanreingold",
+ aes(colour = CurrentEmploymentType,
+ group = CurrentEmploymentType,
+ linewidth = 3 * (...samegroup.. / 8 + .125)),
+ ealpha = 0.25,
+ size = 4, curvature = 0.05,
+ directed = TRUE, arrowsize = 0.5) +
+ scale_colour_brewer("Employment Type", palette = "Set1") +
+ theme_net() + ggtitle("by Volkan OBAN using R - ggnet") +
+ theme(legend.position = "bottom")
> set.seed(10312016)
> ggplot(data = emailnet,
+ aes(from_id = from_id, to_id = to_id)) +
+ geom_net(layout.alg = "fruchtermanreingold",
+ aes(colour = CurrentEmploymentType,
+ group = CurrentEmploymentType,
+ linewidth = 3 * (...samegroup.. / 8 + .125)),
+ ealpha = 0.25,
+ size = 4, curvature = 0.05,
+ directed = TRUE, arrowsize = 0.5) +
+ scale_colour_brewer("Employment Type", palette = "Set1") +
+ theme_net() +
+ theme(legend.position = "bottom")
>
geomnet
> library(geomnet)
> data(madmen, package = "geomnet")
>
> # code for geom_net
> # data step: merge edges and nodes by the "from" column
>
> MMnet <- fortify(as.edgedf(madmen$edges), madmen$vertices)
set.seed(10052016)
ggplot(data = MMnet, aes(from_id = from_id, to_id = to_id)) +
geom_net(aes(colour = Gender), layout.alg = "kamadakawai",
size = 2, labelon = TRUE, vjust = -0.6, ecolour = "grey60",
directed =FALSE, fontsize = 3, ealpha = 0.5) +
scale_colour_manual(values = c("#FF69B4", "#0099ff")) +
xlim(c(-0.05, 1.05)) +
theme_net() +
theme(legend.position = "bottom")
Residuals
fit <- lm(mpg ~ hp, data = mtcars)
d <- mtcars
fit <- lm(mpg ~ hp, data = d)
d$predicted <- predict(fit) # Save the predicted values
d$residuals <- residuals(fit) # Save the residual values
# Quick look at the actual, predicted, and residual values
library(dplyr)
d %>% select(mpg, predicted, residuals) %>% head()
ggplot(d, aes(x = hp, y = mpg)) +
geom_smooth(method = "lm", se = FALSE, color = "lightgrey") +
geom_segment(aes(xend = hp, yend = predicted), alpha = .2) +
# > Color adjustments made here...
geom_point(aes(color = abs(residuals))) + # Color mapped to abs(residuals)
scale_color_continuous(low = "black", high = "red") + # Colors to use here
guides(color = FALSE) + # Color legend removed
# <
geom_point(aes(y = predicted), shape = 1) +
theme_bw()
and
// another visualization
ggplot(d, aes(x = hp, y = mpg)) +
geom_smooth(method = "lm", se = FALSE, color = "lightgrey") +
geom_segment(aes(xend = hp, yend = predicted), alpha = .2) +
# > Color AND size adjustments made here...
geom_point(aes(color = abs(residuals), size = abs(residuals))) + # size also mapped
scale_color_continuous(low = "black", high = "red") +
guides(color = FALSE, size = FALSE) + # Size legend also removed
# <
geom_point(aes(y = predicted), shape = 1) +
theme_bw()
chorddiagram
library(dplyr)
titanic_tbl <- dplyr::tbl_df(Titanic)
titanic_tbl <- titanic_tbl %>%
mutate_each(funs(factor), Class:Survived)
by_class_survival <- titanic_tbl %>%
group_by(Class, Survived) %>%
summarize(Count = sum(n))
titanic.mat <- matrix(by_class_survival$Count, nrow = 4, ncol = 2)
dimnames(titanic.mat ) <- list(Class = levels(titanic_tbl$Class),
Survival = levels(titanic_tbl$Survived))
print(titanic.mat)
groupColors <- c("#2171b5", "#6baed6", "#bdd7e7", "#bababa", "#d7191c", "#1a9641")
chorddiag(titanic.mat, type = "bipartite",
groupColors = groupColors,
tickInterval = 50)
circos
library(migest)
demo(cfplot_nat, package = "migest", ask = FALSE)
circos
library("migest")
demo(cfplot_reg2, package = "migest", ask = FALSE)
Plot
library(dplyr)
> library(ggplot2)
>
> # Read data from the web
> url = "https://gist.githubusercontent.com/stephenturner/806e31fce55a8b7175af/raw/1a507c4c3f9f1baaa3a69187223ff3d3050628d4/results.txt"
>
> results = read.table(url, header=TRUE)
> results = mutate(results, sig=ifelse(results$padj<0.05, "FDR<0.05", "Not Sig"))
>
> p = ggplot(results, aes(log2FoldChange, -log10(pvalue))) +
+ geom_point(aes(col=sig)) + ggtitle("by Volkan OBAN using R") +
+ scale_color_manual(values=c("darkblue", "purple"))
> p
> p+geom_text(data=filter(results, padj<0.05), aes(label=Gene))
> library(ggrepel)
>
> p+geom_text_repel(data=filter(results, padj<0.05), aes(label=Gene))
> library(ggthemes)
> library(ggrepel)
>
> p+geom_text_repel(data=filter(results, padj<0.05), aes(label=Gene)) + theme_wsj() + scale_colour_wsj("colors6", "")
or
> p+geom_text_repel(data=filter(results, padj<0.05), aes(label=Gene)) + theme_solarized(light = FALSE) +
+ scale_colour_solarized("red")
ggplot2
library(dplyr)
library(ggplot2)
# Read data from the web
url = "https://gist.githubusercontent.com/stephenturner/806e31fce55a8b7175af/raw/1a507c4c3f9f1baaa3a69187223ff3d3050628d4/results.txt"
results = read.table(url, header=TRUE)
results = mutate(results, sig=ifelse(results$padj<0.05, "FDR<0.05", "Not Sig"))
p = ggplot(results, aes(log2FoldChange, -log10(pvalue))) +
geom_point(aes(col=sig)) +
scale_color_manual(values=c("red", "black"))
p
p+geom_text(data=filter(results, padj<0.05), aes(label=Gene))
Boxplot for Time Series
code:
library(RColorBrewer)
# Create Data
days=rep(c("monday","tuesday","wenesday","thursday","friday","saturday","sunday") , each=120)
time=rep (rep( paste(seq(0,22,2),seq(2,24,2),sep="-") , each=10 ) , 7)
value=rep ( rep(seq(0,22,2) , each=10 ) , 7)+rnorm(mean=10, sd=10 , length(time))
data=data.frame(days, time, value)
# Create a color palette
my_colors = brewer.pal(9, "Blues")
my_colors = colorRampPalette(my_colors)(12)
# Make the boxplot
boxplot(data$value ~ data$time+data$days , xaxt="n" , xlab="" , col=my_colors , pch=20 , cex=0.3 , ylab="value" )
abline(v= seq(0, 12*7, 12) +0.5 , col="grey")
axis(1, labels=unique(days) , at=seq(6,12*7,12) )
# Add general trend
a=aggregate(data$value , by=list(data$time, data$days) , mean)
lines(a[,3], type="l" , col="red" , lwd=2)
rcharts
ref. and codes: http://timelyportfolio.blogspot.com.tr/2013/06/r-plotting-financial-time-series.html
dygraphs
> library(dygraphs)
> dygraph(ldeaths) %>%
+ dyRangeSelector() %>%
+ dyUnzoom()
> library(xts)
> data(sample_matrix)
> library(dygraphs)
> dygraph(sample_matrix) %>%
+ dyCandlestick()
> library(xts)
> data(sample_matrix)
> library(dygraphs)
> dygraph(sample_matrix, main = "by Volkan OBAN using R - dygraphs- Candlestick") %>%
dyCandlestick()
dygraphs
library(quantmod)
library(dygraphs)
tickers <- c("AAPL", "MSFT")
getSymbols(tickers)
closePrices <- do.call(merge, lapply(tickers, function(x) Cl(get(x))))
dateWindow <- c("2008-01-01", "2009-01-01")
dygraph(closePrices, main = "Value", group = "stock") %>%
dyRebase(value = 100) %>%
dyRangeSelector(dateWindow = dateWindow)
dygraph(closePrices, main = "Percent", group = "stock") %>%
dyRebase(percent = TRUE) %>%
dyRangeSelector(dateWindow = dateWindow)
dygraph(closePrices, main = "None", group = "stock") %>%
dyRangeSelector(dateWindow = dateWindow)
heatmap.2
> data(USJudgeRatings)
> symnum( cU <- cor(USJudgeRatings) )
hM <- format(round(cU, 2))
> hM
heatmap.2(cU, Rowv=FALSE,main=" Volkan OBAN using R - gplots heatmap.2", symm=TRUE, col=rev(heat.colors(16)),
+ distfun=function(c) as.dist(1 - c), trace="none",
+ cellnote=hM)
harmonograph
f1=jitter(sample(c(2,3),1));f2=jitter(sample(c(2,3),1));f3=jitter(sample(c(2,3),1));f4=jitter(sample(c(2,3),1))
d1=runif(1,0,1e-02);d2=runif(1,0,1e-02);d3=runif(1,0,1e-02);d4=runif(1,0,1e-02)
p1=runif(1,0,pi);p2=runif(1,0,pi);p3=runif(1,0,pi);p4=runif(1,0,pi)
xt = function(t) exp(-d1*t)*sin(t*f1+p1)+exp(-d2*t)*sin(t*f2+p2)
yt = function(t) exp(-d3*t)*sin(t*f3+p3)+exp(-d4*t)*sin(t*f4+p4)
t=seq(1, 100, by=.001)
dat=data.frame(t=t, x=xt(t), y=yt(t))
with(dat, plot(x,y, type="l", xlim =c(-2,2), ylim =c(-2,2), xlab = "", ylab = "", xaxt='n', yaxt='n'))
BoxPlot
> library(mvtnorm)
> k <- 100 # Number of samples for each correlation
> N <- 20 # Size of the samples
> r <- seq(-1, 1, by=.2) # The true correlations
> n <- length(r)
> rr <- matrix(NA, nr=n, nc=k)
> for (i in 1:n) {
+ for (j in 1:k) {
+ x <- rmvnorm(N, sigma=matrix(c(1, r[i], r[i], 1), nr=2, nc=2))
+ rr[i,j] <- cor( x[,1], x[,2] )
+ }
+ }
> estimated.correlation <- as.vector(rr)
> true.correlation <- r[row(rr)]
> boxplot(estimated.correlation ~ true.correlation,
+ col = "purple",
+ xlab = "True correlation", main="y Volkan OBAN using R",
+ ylab = "Estimated correlation" )
> library(mvtnorm)
> k <- 100 # Number of samples for each correlation
> N <- 20 # Size of the samples
> r <- seq(-1, 1, by=.2) # The true correlations
> n <- length(r)
> rr <- matrix(NA, nr=n, nc=k)
> for (i in 1:n) {
+ for (j in 1:k) {
+ x <- rmvnorm(N, sigma=matrix(c(1, r[i], r[i], 1), nr=2, nc=2))
+ rr[i,j] <- cor( x[,1], x[,2] )
+ }
+ }
> estimated.correlation <- as.vector(rr)
> true.correlation <- r[row(rr)]
> boxplot(estimated.correlation ~ true.correlation,
+ col = "lightpink3",
+ xlab = "True correlation", main="by Volkan OBAN using R",
+ ylab = "Estimated correlation" )
geom_boxplot() + facet_wrap(~ ) ggplot2
ggplot(diamonds, aes(x = cut, y = price, fill = clarity)) +
+ geom_boxplot() +
+ facet_wrap(~ clarity, scale = "free")
geom_boxplot() + facet_wrap(~ ) ggplot2
> library(ggplot2)
>
> # create fake dataset with additional attributes - sex, sample, and temperature
> x <- data.frame(values = c(runif(100, min = 0), runif(100), runif(100, max = 3), runif(100)),
letter = rep(c('o', 'v'), each = 100),
sample = rep(c('VVV', 'OOO'), each = 200),
s = sample(c('1984', '1990', '2000', '2019'), 400, replace = TRUE) )
>
>
> ggplot(x, aes(x = sample, y = values, fill = letter)) +
+ geom_boxplot() +
+ facet_wrap(~ s)
ggplot2 facet_wrap
> p<- ggplot(diamonds, aes(x=cut, y=price, fill=cut))
> p + geom_boxplot() + facet_wrap(~clarity, scales="free")
ggplot2
require (ggplot2)
> require (plyr)
> library(reshape2)
>
> set.seed(1234)
> x<- rnorm(100)
> y.1<-rnorm(80)
> y.2<-rnorm(60)
> y.3<-rnorm(75)
> y.4<-rnorm(105)
> y.5<-rnorm(80)
> y.6<-rnorm(90)
> df<- (as.data.frame(cbind(x,y.1,y.2,y.3,y.4,y.5,y.6)))
ggplot(dfmelt, aes(value, x, group = round_any(x, 0.5), fill=variable))+
+ geom_boxplot() +
+ geom_jitter() +
+ facet_wrap(~variable)
threejs
N <- 100
i <- sample(3, N, replace=TRUE)
x <- matrix(rnorm(N*3),ncol=3)
lab <- c("small", "bigger", "biggest")
scatterplot3js(x, color=rainbow(N), labels=lab[i], size=i, renderer="canvas")
threejs
> data(flights)
> # Approximate locations as factors
> dest <- factor(sprintf("%.2f:%.2f",flights[,3], flights[,4]))
> # A table of destination frequencies
> freq <- sort(table(dest), decreasing=TRUE)
> # The most frequent destinations in these data, possibly hub airports?
> frequent_destinations <- names(freq)[1:10]
> # Subset the flight data by destination frequency
> idx <- dest %in% frequent_destinations
> frequent_flights <- flights[idx, ]
> # Lat/long and counts of frequent flights
> ll <- unique(frequent_flights[,3:4])
> # Plot frequent destinations as bars, and the flights to and from
> # them as arcs. Adjust arc width and color by frequency.
> globejs(lat=ll[,1], long=ll[,2], arcs=frequent_flights,
+ arcsHeight=0.3, arcsLwd=2, arcsColor="#FFFFFF", arcsOpacity=0.15,
+ atmosphere=TRUE, color="#000080", pointsize=0.5)
>
rbokeh
> library(maps)
> data(world.cities)
> caps <- subset(world.cities, capital == 1)
> caps$population <- prettyNum(caps$pop, big.mark = ",")
> figure(width = 800, height = 450,title="by Volkan OBAN using R - rbokeh -- data(world.cities)", padding_factor = 0) %>%
+ ly_map("world", col = "darkblue") %>%
+ ly_points(long, lat, data = caps, size = 5,
+ hover = c(name, country.etc, population))
wordcloud
library(wordcloud)
>
> #Create a list of words (Random words concerning my work)
> a=c("VOLKAN OBAN","Mathematics","Data Science","Machine Learning","scikit-learn","solution","MLib","Apache Spark","Analysis","Big Data","Science","Statistics","Data", "Programming","ggplot2","matplotlib-seaborn","Volkan","VOLKAN","Istanbul","kNN","R", "R","Data-Viz","Python","kmeans","Programming","Graph Theory ","Operations Research", "Predictive Analytics","Clustering","Data Science","Prescriptive Analytics","Analytics","Classification")
>
> #I give a frequency to each word of this list
> b=sample(seq(0,1,0.01) , length(a) , replace=TRUE)
> par(bg="deeppink4")
> wordcloud(a , b , col=terrain.colors(length(a) , alpha=0.9) , rot.per=0.3 )
art in R. ref: Gaston Sanchez
x = seq(-50, 50, by = 1)
y = -(x^2)
# set graphic parameters
op = par(bg = 'black', mar = rep(0.5, 4))
# Plot
plot(y, x, type = 'n')
lines(y, x, lwd = 2*runif(1), col = hsv(0.08, 1, 1, alpha = runif(1, 0.5, 0.9)))
for (i in seq(10, 2500, 10))
{
lines(y-i, x, lwd = 2*runif(1), col = hsv(0.08, 1, 1, alpha = runif(1, 0.5, 0.9)))
}
for (i in seq(500, 600, 10))
{
lines(y - i, x, lwd = 2*runif(1), col = hsv(0, 1, 1, alpha = runif(1, 0.5, 0.9)))
}
for (i in seq(2000, 2300, 10))
{
lines(y - i, x, lwd = 2*runif(1), col = hsv(0, 1, 1, alpha = runif(1, 0 .5, 0.9)))
}
for (i in seq(100, 150, 10))
{
lines(y - i, x, lwd = 2*runif(1), col = hsv(0, 1, 1, alpha = runif(1, 0.5, 0.9)))
}
# signature
legend("bottomright", legend="© Gaston Sanchez", bty = "n", text.col="gray70")
Plot
library(RColorBrewer)
>
> # Classic palette BuPu, with 4 colors
> coul = brewer.pal(4, "BuPu")
>
> # I can add more tones to this palette :
> coul = colorRampPalette(coul)(25)
>
> # Plot it
> pie(rep(1, length(coul)), col = coul , main=" R - piechart - RColorBrewer ")
Plot3D package
require(plot3D)
Zorunlu paket yükleniyor: plot3D
> lon <- seq(165.5, 188.5, length.out = 30)
> lat <- seq(-38.5, -10, length.out = 30)
> xy <- table(cut(quakes$long, lon),
+ cut(quakes$lat, lat))
> xmid <- 0.5*(lon[-1] + lon[-length(lon)])
> ymid <- 0.5*(lat[-1] + lat[-length(lat)])
>
> par (mar = par("mar") + c(0, 0, 0, 2))
> hist3D(x = xmid, y = ymid, z = xy,
+ zlim = c(-20, 40), main = " Earth quakes",
+ ylab = "latitude", xlab = "longitude",
+ zlab = "counts", bty= "g", phi = 5, theta = 25,
+ shade = 0.2, col = "white", border = "black",
+ d = 1, ticktype = "detailed")
>
> with (quakes, scatter3D(x = long, y = lat,
+ z = rep(-20, length.out = length(long)),
+ colvar = quakes$depth, col = gg.col(100),
+ add = TRUE, pch = 18, clab = c("depth", "m"),
+ colkey = list(length = 0.5, width = 0.5,
+ dist = 0.05, cex.axis = 0.8, cex.clab = 0.8)
+ ))
ggplot2
ggplot(train, aes(Outlet_Identifier, Item_Outlet_Sales)) + geom_boxplot(fill = "mediumpurple4")+
+ scale_y_continuous("Item Outlet Sales", breaks= seq(0,15000, by=500))+
+ labs(title = " R - ggplot2", x = "Outlet Identifier")
data:https://docs.google.com/spreadsheets/d/1PR5StHxg2jlMCb4IUilGSEwhylXn-3q3EJucSaVolCU/edit#gid=0
scatterplot
train<-read.csv(mart.csv)
Error in read.table(file = file, header = header, sep = sep, quote = quote, :
object 'mart.csv' not found
> train <- read.csv(file="mart.csv", header=TRUE, sep=",")
> ggplot(train, aes(Item_Visibility, Item_MRP)) + geom_point(aes(color = Item_Type)) +
+ scale_x_continuous("Item Visibility", breaks = seq(0,0.35,0.05))+
+ scale_y_continuous("Item MRP", breaks = seq(0,270,by = 30))+
+ theme_bw()
data:https://docs.google.com/spreadsheets/d/1PR5StHxg2jlMCb4IUilGSEwhylXn-3q3EJucSaVolCU/edit#gid=0
ggplot2
ref: https://www.r-bloggers.com/improved-net-stacked-distribution-graphs-via-ggplot2-trickery/
ggplot2
library("ggplot2")
> data <- read.csv("ggplot-data.csv", header=TRUE, nrows=200)
> gg <- ggplot(data, aes(x=Keyword))
> gg <- gg + geom_bar(aes(weight=Traffic, fill=Country) + coord_flip()
+ )
> gg
> data$kw <- reorder(data$Keyword, data$Traffic)
> gg <- ggplot(data, aes(x=kw))
>
> gg <- gg + geom_bar(aes(weight=Traffic, fill=Country)) + coord_flip()
>
> gg
> gg <- ggplot(data, aes(x=kw))
>
> gg <- gg + geom_bar(aes(weight=Traffic, fill=Country)) + coord_flip()
>
> gg
ggplot2 facet_wrap
> c <- ggplot(diamonds, aes(clarity, fill=cut)) + geom_bar()
> c + facet_wrap(~cut, scales = "free_y") + coord_flip(
ggplot2
library(ggplot2)
> df <- structure(c(106487, 495681, 1597442,
+ 2452577, 2065141, 2271925, 4735484, 3555352,
+ 8056040, 4321887, 2463194, 347566, 621147,
+ 1325727, 1123492, 800368, 761550, 1359737,
+ 1073726, 36, 53, 141, 41538, 64759, 124160,
+ 69942, 74862, 323543, 247236, 112059, 16595,
+ 37028, 153249, 427642, 1588178, 2738157,
+ 2795672, 2265696, 11951, 33424, 62469,
+ 74720, 166607, 404044, 426967, 38972, 361888,
+ 1143671, 1516716, 160037, 354804, 996944,
+ 1716374, 1982735, 3615225, 4486806, 3037122,
+ 17, 54, 55, 210, 312, 358, 857, 350, 7368,
+ 8443, 6286, 1750, 7367, 14092, 28954, 80779,
+ 176893, 354939, 446792, 33333, 69911, 53144,
+ 29169, 18005, 11704, 13363, 18028, 46547,
+ 14574, 8954, 2483, 14693, 25467, 25215,
+ 41254, 46237, 98263, 185986), .Dim = c(19,
+ 5), .Dimnames = list(c("1820-30", "1831-40",
+ "1841-50", "1851-60", "1861-70", "1871-80",
+ "1881-90", "1891-00", "1901-10", "1911-20",
+ "1921-30", "1931-40", "1941-50", "1951-60",
+ "1961-70", "1971-80", "1981-90", "1991-00",
+ "2001-06"), c("Europe", "Asia", "Americas",
+ "Africa", "Oceania")))
> library(reshape)
Attaching package: ‘reshape’
The following objects are masked from ‘package:plyr’:
rename, round_any
The following object is masked from ‘package:Matrix’:
expand
> df.m <- melt(df)
> df.m <- rename(df.m, c(X1 = "Period", X2 = "Region"))
a <- ggplot(df.m, aes(x = Period, y = value/1e+06,
+ fill = Region)) + options(title = "Migration to the United States by Source Region (1820-2006)") +
+ labs(x = NULL, y = "Number of People (in millions)n",
+ fill = NULL)
> b <- a + geom_bar(stat = "identity", position = "stack")
> b
c <- b+ facet_grid(Region ~ .) + options(legend.position = "none")
> c
> total <- cast(df.m, Period ~ ., sum)
> total <- rename(total, c(`(all)` = "value"))
> total$Region <- "Total"
> df.m.t <- rbind(total, df.m)
> c1 <- c %+% df.m
> total <- cast(df.m, Period ~ ., sum)
> total <- rename(total, c(`(all)` = "value"))
> total$Region <- "Total"
> df.m.t <- rbind(total, df.m)
> c1 <- c %+% df.m
> c1
> c2 <- c1 + facet_grid(Region ~ ., scale = "free_y")
> c2
ggplot2
ibrary(ggplot2)
> library(ggthemes)
> library(extrafont)
Registering fonts with R
> library(plyr)
Attaching package: ‘plyr’
The following object is masked from ‘package:network’:
is.discrete
> library(scales)
Attaching package: ‘scales’
The following object is masked _by_ ‘.GlobalEnv’:
cscale
> charts.data <- read.csv("data.csv")
> p <- ggplot() + geom_bar(aes(y = percentage, x = year, fill = product), data = charts.data,stat="identity")
p <- p + geom_text(data=charts.data, aes(x = year, y = percentage,
+ label = paste0(percentage,"%")), size=4)
p
ggplot2
Year <- c(rep(c("1984-01", "1987-05", "1990-06", "2005-01"), each = 4))
Category <- c(rep(c("V", "O", "R", "D"), times = 4))
Frequency <- c(174, 248, 201, 326, 215, 428, 309, 365, 419, 652, 231, 695, 144, 452, 281, 210)
Data <- data.frame(Year, Category, Frequency)
ggplot(Data, aes(x = Year, y = Frequency, fill = Category, label = Frequency)) +
geom_bar(stat = "identity") +
geom_text(size = 3, position = position_stack(vjust = 0.5))
ggplot2 facet_grid
> ggplot(diamonds, aes(clarity)) +
+ geom_bar(aes(fill = cut)) +
+ facet_grid(cut ~ .)
Gauge Chart in R
ref and code :https://www.r-bloggers.com/gauge-chart-in-r/
gauge
gg.gauge <- function(pos,breaks=c(0,42,58,100)) {
+ require(ggplot2)
+ get.poly <- function(a,b,r1=0.5,r2=1.0) {
+ th.start <- pi*(1-a/100)
+ th.end <- pi*(1-b/100)
+ th <- seq(th.start,th.end,length=100)
+ x <- c(r1*cos(th),rev(r2*cos(th)))
+ y <- c(r1*sin(th),rev(r2*sin(th)))
+ return(data.frame(x,y))
+ }
+ ggplot()+ ggtitle("by Volkan OBAN using R \n Gauge") +
+ geom_polygon(data=get.poly(breaks[1],breaks[2]),aes(x,y),fill="green")+
+ geom_polygon(data=get.poly(breaks[2],breaks[3]),aes(x,y),fill="pink")+
+ geom_polygon(data=get.poly(breaks[3],breaks[4]),aes(x,y),fill="purple")+
+ geom_polygon(data=get.poly(pos-1,pos+1,0.2),aes(x,y))+
+ geom_text(data=as.data.frame(breaks), size=5, fontface="bold", vjust=0,
+ aes(x=1.1*cos(pi*(1-breaks/100)),y=1.1*sin(pi*(1-breaks/100)),label=paste0(breaks,"%")))+
+ annotate("text",x=0,y=0,label=pos,vjust=0,size=8,fontface="bold")+
+ coord_fixed()+
+ theme_bw()+
+ theme(axis.text=element_blank(),
+ axis.title=element_blank(),
+ axis.ticks=element_blank(),
+ panel.grid=element_blank(),
+ panel.border=element_blank())
+ }
> gg.gauge(52,breaks=c(0,42,58,100)
+
+ )
> library(gridExtra)
> grid.newpage()
> grid.draw(arrangeGrob(gg.gauge(22),gg.gauge(36),
+ gg.gauge(71),gg.gauge(95),ncol=2))
gauge
gg.gauge <- function(pos,breaks=c(0,42,58,100)) {
+ require(ggplot2)
+ get.poly <- function(a,b,r1=0.5,r2=1.0) {
+ th.start <- pi*(1-a/100)
+ th.end <- pi*(1-b/100)
+ th <- seq(th.start,th.end,length=100)
+ x <- c(r1*cos(th),rev(r2*cos(th)))
+ y <- c(r1*sin(th),rev(r2*sin(th)))
+ return(data.frame(x,y))
+ }
+ ggplot()+ ggtitle("by Volkan OBAN using R \n Gauge") +
+ geom_polygon(data=get.poly(breaks[1],breaks[2]),aes(x,y),fill="green")+
+ geom_polygon(data=get.poly(breaks[2],breaks[3]),aes(x,y),fill="pink")+
+ geom_polygon(data=get.poly(breaks[3],breaks[4]),aes(x,y),fill="purple")+
+ geom_polygon(data=get.poly(pos-1,pos+1,0.2),aes(x,y))+
+ geom_text(data=as.data.frame(breaks), size=5, fontface="bold", vjust=0,
+ aes(x=1.1*cos(pi*(1-breaks/100)),y=1.1*sin(pi*(1-breaks/100)),label=paste0(breaks,"%")))+
+ annotate("text",x=0,y=0,label=pos,vjust=0,size=8,fontface="bold")+
+ coord_fixed()+
+ theme_bw()+
+ theme(axis.text=element_blank(),
+ axis.title=element_blank(),
+ axis.ticks=element_blank(),
+ panel.grid=element_blank(),
+ panel.border=element_blank())
+ }
> gg.gauge(52,breaks=c(0,42,58,100)
+
+ )
DiagrammeR
> spec <- "
+ digraph { 'VOLKAN OBAN \n Data Scientist ' }
+ [1]: LETTERS[1]
+ "
>
>
> grViz(replace_in_spec(spec))
DiagrammeR
> spec <- "
+ digraph { '@1' }
+ [1]: LETTERS[1]
+ "
> grViz(replace_in_spec(spec))
> spec <- "
+ digraph a_nice_graph {
+ node [fontname = Arial]
+ a [label = 'by VOLKAN OBAN using R ']
+ b [label = 'Mathematics']
+ c [label = 'Data Science']
+ d [label = 'Analytics']
+ e [label = 'Programming']
+ f [label = 'Machine Learning']
+ g [label = 'Python']
+ h [label = 'Statistics']
+ i [label = 'R']
+ j [label = 'Istanbul']
+ a -> { b c d e f g h i j}
+ }
+ [1]: 'top'
+ [2]: 10:20
+ "
> grViz(replace_in_spec(spec))
>
ggplot2 and ggthemr
> ggthemr('lilac')
>ggplot(data = mpg, mapping = aes(x = class, y = hwy)) +
+ geom_boxplot() +
+ coord_flip() +
ggplot2 and ggthemr
sea
ggplot(data = mpg, mapping = aes(x = class, y = hwy)) +
+ geom_boxplot() +
+ coord_flip()
ggplot2 and ggthemr
....................
ggplot(data = diamonds) +
geom_bar(mapping = aes(x = cut, fill = clarity), position = "dodge")
ggplot2 and ggthemr
> ggthemr('lilac')
> ggplot(data = diamonds) +
+ geom_bar(mapping = aes(x = cut, fill = clarity), position = "dodge") + ggtitle("by Volkan OBAN using R - ggplot2 and ggthemr packages /data(diamonds)")
ggplot2 and ggthemr
> ggthemr('sea')
> ggplot(data = diamonds) +
+ geom_bar(mapping = aes(x = cut, fill = clarity), position = "dodge") + ggtitle("by Volkan OBAN using R - ggplot2 and ggthemr packages /data(diamonds)")
Visualize kmeans clustering
ref: http://handsondatascience.com/ClustersO.pdf
ggmap
> ds<-map_data("world")
> p <- ggplot(ds, aes( x=long, y=lat, group=group))
> p <-p + geom_polygon() + ggtitle("by Volkan OBAN using R - ggmap")
> p
>
> p <- ggplot(ds, aes(x=long, y=lat, group=group, fill=region))
> p <- p + geom_polygon()
> p <- p + geom_polygon()
> p <- p + theme(legend.position = "none")
> p
Visualize kmeans clustering
> library(rattle) # Load weather dataset. Normalise names normVarNames().
Rattle: A free graphical interface for data mining with R.
Version 4.1.0 Copyright (c) 2006-2015 Togaware Pty Ltd.
Type 'rattle()' to shake, rattle, and roll your data.
> library(randomForest) # Impute missing using na.roughfix().
randomForest 4.6-12
Type rfNews() to see new features/changes/bug fixes.
> # Identify the dataset.
> dsname <- "weather"
> ds <- get(dsname)
> names(ds) <- normVarNames(names(ds))
> vars <- names(ds)
> target <- "rain_tomorrow"
> risk <- "risk_mm"
> id <- c("date", "location")
> # Ignore the IDs and the risk variable.
> ignore <- union(id, if (exists("risk")) risk)
> # Ignore variables which are completely missing.
> mvc <- sapply(ds[vars], function(x) sum(is.na(x))) # Missing value count.
> mvn <- names(ds)[(which(mvc == nrow(ds)))] # Missing var names.
> ignore <- union(ignore, mvn)
> # Initialise the variables
> vars <- setdiff(vars, ignore)
> # Variable roles.
> inputc <- setdiff(vars, target)
> inputi <- sapply(inputc, function(x) which(x == names(ds)), USE.NAMES=FALSE)
> numi <- intersect(inputi, which(sapply(ds, is.numeric)))
> numc <- names(ds)[numi]
> cati <- intersect(inputi, which(sapply(ds, is.factor)))
> catc <- names(ds)[cati]
> # Impute missing values, but do this wisely - understand why missing.
> if (sum(is.na(ds[vars]))) ds[vars] <- na.roughfix(ds[vars])
> # Number of observations.
> nobs <- nrow(ds)
> model <- m.km <- kmeans(ds, 10)
> model <- m.kms <- kmeans(scale(ds[numi]), 10)
> model$size
[1] 34 54 15 70 24 32 30 44 43 20
> library(ggplot2)
> library(reshape)
Attaching package: ‘reshape’
The following object is masked from ‘package:Matrix’:
expand
> nclust <- 4
> model <- m.kms <- kmeans(scale(ds[numi]), nclust)
> dscm <- melt(model$centers)
> names(dscm) <- c("Cluster", "Variable", "Value")
> dscm$Cluster <- factor(dscm$Cluster)
> dscm$Order <- as.vector(sapply(1:length(numi), rep, nclust))
> p <- ggplot(dscm,
+ aes(x=reorder(Variable, Order),
+ y=Value, group=Cluster, colour=Cluster))
> p <- p + coord_polar()
> p <- p + geom_point()
> p <- p + geom_path()
> p <- p + labs(x=NULL, y=NULL)
> p <- p + theme(axis.ticks.y=element_blank(), axis.text.y = element_blank())
> p
>
Visualize kmeans clustering
> set.seed(32297)
d <- data.frame(x=runif(100),y=runif(100))
> clus <- kmeans(d,centers=5)
> d$cluster <- clus$cluster
> library('ggplot2')
> library('grDevices')
> h <- do.call(rbind,
+ lapply(unique(clus$cluster),
+ function(c) { f <- subset(d,cluster==c); f[chull(f),]}))
> ggplot() +
+ geom_text(data=d,aes(label=cluster,x=x,y=y,
+ color=cluster),size=3) +
+ geom_polygon(data=h,aes(x=x,y=y,group=cluster,fill=as.factor(cluster)),
+ alpha=0.4,linetype=0) +
+ theme(legend.position = "none")
wordcloud
> library(wordcloud)
>
> #Create a list of words (Random words concerning my work)
> a=c("Volkan OBAN","Clustering","Turkey","Istanbul","Classification","Istanbul Technical University","Mathematics",
+ "Data Science","Analysis","Machine Learning","Science","Statistics","Data",
+ "Programming","Clustering","Recommedation","Visualization","Spark","Business","VOLKAN","R", "R",
+ "Data-Viz","Python","Linux","Programming","Graphs","Numbers", "Big Data",
+ "Computing","Data-Science","Analytics","GitHub","OBAN")
>
> #I give a frequency to each word of this list
> b=sample(seq(0,1,0.01) , length(a) , replace=TRUE)
>
> #The package will automatically make the wordcloud ! (I add a black background)
> par(bg="hotpink4")
> wordcloud(a , b , col=terrain.colors(length(a) , alpha=0.9) , rot.per=0.3 )
>
Plot
> moxbuller = function(n) {
+ u = runif(n)
+ v = runif(n)
+ x = cos(2*pi*u)*sqrt(-2*log(v))
+ y = sin(2*pi*v)*sqrt(-2*log(u))
+ r = list(x=x, y=y)
+ return(r)
+ }
> r = moxbuller(50000)
> par(bg="aliceblue")
> par(mar=c(0,0,0,0))
> plot(r$x,r$y, pch=".", col="hotpink4",main=" \n by Volkan OBAN using R", cex=1.2)
Plot
library(magrittr)
>
> add_line_points2 <- function(plot, df, ...) {
+ plot +
+ geom_line(aes(x = Time, y = weight, group = Chick), ..., data = df) +
+ geom_point(aes(x = Time, y = weight), ..., data = df)
+ }
>
> (plot4 <- ggplot() %>% add_line_points2(diet1)
+ %>% add_line_points2(diet2, colour = "red")
Plot
> library(ggplot2)
>
> data(ChickWeight)
> diet1 <- subset(ChickWeight, Diet == 1)
> diet2 <- subset(ChickWeight, Diet == 2)
> add_line <- function(df) {
+ geom_line(aes(x = Time, y = weight, group = Chick), data = df)
+ }
>
> add_points <- function(df) {
+ geom_point(aes(x = Time, y = weight), data = df)
+ }
>
> add_line_points <- function(df) {
+ add_line(df) + add_points(df)
+ }
(p <- ggplot(aes(x = Time, y = weight, group = Chick, colour = Diet),
+ data = ChickWeight) +
+ geom_line() + geom_point())
Plot
library(ggplot2)
>
> data(ChickWeight)
> diet1 <- subset(ChickWeight, Diet == 1)
> diet2 <- subset(ChickWeight, Diet == 2)
> add_line <- function(df) {
+ geom_line(aes(x = Time, y = weight, group = Chick), data = df)
+ }
>
> add_points <- function(df) {
+ geom_point(aes(x = Time, y = weight), data = df)
+ }
>
> add_line_points <- function(df) {
+ add_line(df) + add_points(df)
p <- ggplot(aes(x = Time, y = weight, group = Chick), data = diet1) +
+ geom_line() + geom_point()
lattice package --wireframe and cloud
cloud(Sepal.Length ~ Petal.Length * Petal.Width | Species, data = iris,
screen = list(x = -90, y = 70),main="by Volkan OBAN using R", distance = .4, zoom = .6)
timeseries zoo package.
library(quantmod)
> tckrs <- c("SPY", "QQQ", "GDX", "DBO", "VWO")
> getSymbols(tckrs, from = "2007-01-01"
SPY.Close <- SPY[,4]
> QQQ.Close <- QQQ[,4]
> GDX.Close <- GDX[,4]
> DBO.Close <- DBO[,4]
> VWO.Close <- VWO[,4]
> SPY1 <- as.numeric(SPY.Close[1])
> QQQ1 <- as.numeric(QQQ.Close[1])
> GDX1 <- as.numeric(GDX.Close[1])
> DBO1 <- as.numeric(DBO.Close[1])
> VWO1 <- as.numeric(VWO.Close[1]
+ )
> SPY <- SPY.Close/SPY1
> QQQ <- QQQ.Close/QQQ1
> GDX <- GDX.Close/GDX1
> DBO <- DBO.Close/DBO1
> VWO <- VWO.Close/VWO1
> basket <- cbind(SPY, QQQ, GDX, DBO, VWO
+ )
> zoo.basket <- as.zoo(basket
+ )
> tsRainbow <- rainbow(ncol(zoo.basket))
> # Plot the overlayed series
> plot(x = zoo.basket, ylab = "Cumulative Return", main = "by Volkan OBAN using R \n Cumulative Returns",
+ col = tsRainbow, screens = 1)
> # Set a legend in the upper left hand corner to match color to return series
> legend(x = "topleft", legend = c("SPY", "QQQ", "GDX", "DBO", "VWO"),
lty = 1,col = tsRainbow)
ggcyto from bioconductor
> library(ggcyto)
> data(GvHD)
> fs <- GvHD[subset(pData(GvHD), Patient %in%5:7 & Visit %in% c(5:6))[["name"]]]
> fr <- fs[[1]]
> p <- ggcyto(fs, aes(x = `FSC-H`))
> p <- ggcyto(fs, aes(x = `FSC-H`, y = `SSC-H`)) + ggtitle("by Volkan OBAN using R")
> p <- p + geom_hex(bins = 128)
> p
Warning message:
Removed 257 rows containing missing values (geom_hex).
> p + scale_fill_gradientn(colours = rainbow(7), trans = "sqrt")
> library(knitr)
> library(RColorBrewer)
> p + scale_fill_gradientn(colours = brewer.pal(n=8,name="PiYG"),trans="sqrt")
ggcyto from bioconductor
library(ggcyto)
data(GvHD)
fs <- GvHD[subset(pData(GvHD), Patient %in%5:7 & Visit %in% c(5:6))[["name"]]]
fr <- fs[[1]]
p1 <- ggplot(mapping = aes(x = `FSC-H`, y = `SSC-H`)) + myColor_scale_fill + facet_grid(Patient~Visit)
p1 + stat_binhex(data = fs, bin = 64)
ggplot2 and ggthemes
> p<-ggplot(diamonds, aes(cut, price)) +
+ geom_boxplot() +
+ coord_flip() + theme_solarized() +
+ scale_colour_solarized("purple") + ggtitle("by Volkan OBAN using R \n data(diamonds) ") + theme(plot.title = element_text(size = 12, face = "bold")
+ )
> p
SVM plot
> data(iris)
> m2 <- svm(Species~., data = iris)
> plot(m2, iris, Petal.Width ~ Petal.Length,
+ slice = list(Sepal.Width = 3, Sepal.Length = 4))
rasterVis
u1 <- cos(y) * cos(x)
v1 <- cos(y) * sin(x)
u2 <- sin(y) * sin(x)
v2 <- sin(y) * cos(x)
field <- stack(u, u1, u2, v, v1, v2)
names(field) <- c('u', 'u1', 'u2', 'v', 'v1', 'v2')
vectorplot(field, isField='dXY',
narrows=300, lwd.arrows=.4,
par.settings=BTCTheme(),
layout=c(3, 1))
## uLayer and vLayer define which layers contain
## horizontal and vertical components, respectively
vectorplot(field, isField='dXY',
narrows=300,
uLayer=1:3,
vLayer=6:4)
rasterVis
u1 <- cos(y) * cos(x)
v1 <- cos(y) * sin(x)
u2 <- sin(y) * sin(x)
v2 <- sin(y) * cos(x)
field <- stack(u, u1, u2, v, v1, v2)
names(field) <- c('u', 'u1', 'u2', 'v', 'v1', 'v2')
vectorplot(field, isField='dXY',
narrows=300, lwd.arrows=.4,
par.settings=BTCTheme(),
layout=c(3, 1))
## uLayer and vLayer define which layers contain
## horizontal and vertical components, respectively
vectorplot(field, isField='dXY',
narrows=300,
uLayer=1:3,
vLayer=6:4)
SWMPr and oce
library(SWMPr)
library(oce)
# clean input data, one hour time step, subset, fill gaps
dat <- qaqc(apadbwq) %>%
setstep(timestep = 60) %>%
subset(., subset = c('2013-01-01 0:0', '2013-12-31 0:0'), select = 'depth') %>%
na.approx(maxgap = 1e6)
# get model
datsl <- as.sealevel(elevation = dat$depth, time = dat$datetimestamp)
mod <- tidem(t = datsl)
# add predictions to observed data
dat$Estimated <- predict(mod)
# plot
ggplot(dat, aes(x = datetimestamp, y = Estimated)) +
geom_line() +
theme_bw()
Plot
constituents <- c('M2', 'S2', 'N2', 'K2', 'K1', 'O1', 'P1')
# loop through tidal components, predict each with tidem
preds <- sapply(constituents, function(x){
mod <- tidem(t = datsl, constituent = x)
pred <- predict(mod)
pred - mean(pred)
})
# combine prediction, sum, add time data
predall <- rowSums(preds) + mean(datsl[['elevation']])
preds <- data.frame(time = datsl[['time']], preds, Estimated = predall)
head(preds)
mod <- tidem(t = datsl)
Note: the record is too short to fit for constituents: SA PI1 S1 PSI1 GAM2 H1 H2 T2 R2
>
> # get components of interest
> amps <- data.frame(mod@data[c('name', 'amplitude')]) %>%
+ filter(name %in% constituents) %>%
+ arrange(amplitude)
> amps
name amplitude
1 K2 0.01091190
2 N2 0.01342395
3 S2 0.02904518
4 P1 0.04100388
5 O1 0.11142455
6 M2 0.12005114
7 K1 0.12865764
> dat$Estimated <- predict(mod)
>
> # plot one month
> ggplot(dat, aes(x = datetimestamp, y = depth)) +
+ geom_point() +
+ geom_line(aes(y = Estimated), colour = 'blue') +
+ scale_x_datetime(limits = as.POSIXct(c('2013-07-01', '2013-07-31'))) +
+ scale_y_continuous(limits = c(0.9, 2)) +
+ theme_bw()
SWMPr and oce
library(SWMPr)
Warning message:
package ‘SWMPr’ was built under R version 3.3.3
> library(oce)
>
> # clean, one hour time step, subset, fill gaps
> dat <- qaqc(apadbwq) %>%
+ setstep(timestep = 60) %>%
+ subset(subset = c('2013-01-01 0:0', '2013-12-31 0:0'), select = 'depth') %>%
+ na.approx(maxgap = 1e6)
> datsl <- as.sealevel(elevation = dat$depth, time = dat$datetimestamp)
> plot(datsl,main="by Volkan OBAN using R")
mosaic plot
> library("graphics")
> # Mosaic plot of observed values
> mosaicplot(housetasks, las=2, col="steelblue",
+ main = " \n housetasks - observed counts")
MAPS
> require(maps)
> Tur = map_data('world', region = 'Turkey')
> ggplot(Tur, aes(x = long, y = lat, group = group)) +
+ geom_polygon(fill = 'red', colour = 'black') +ggtitle("TURKEY- TÜRKİYE CENNETİM"
Plot
> c <- ggplot(diamonds, aes(carat, price))
> c + geom_bin2d()
> require(hexbin)
> c + geom_hex()
> c + geom_hex(bins = 10)
ggplot2
> wdata = data.frame(
+ s = factor(rep(c("F", "M"), each=200)),
+ weight = c(rnorm(200, 55), rnorm(200, 58)))
a <- ggplot(wdata, aes(x = weight))
> a + geom_dotplot()
ggplot2
> set.seed(1234)
> wdata = data.frame(
+ s = factor(rep(c("F", "M"), each=200)),
+ weight = c(rnorm(200, 55), rnorm(200, 58)))
> head(wdata)
s weight
1 F 53.79293
2 F 55.27743
3 F 56.08444
4 F 52.65430
5 F 55.42912
6 F 55.50606
> qplot(s, weight, data = wdata, geom = "dotplot",
+ stackdir = "center", binaxis = "y", dotsize = 0.5)
pie chart
> df <- data.frame(
+ group = c("X", "Y", "Z"),
+ value = c(37, 43, 20)
+ )
> head(df)
group value
1 X 37
2 Y 43
3 Z 20
> library(ggplot2)
> bp<- ggplot(df, aes(x="", y=value, fill=group))+
+ geom_bar(width = 1, stat = "identity")
> bp
> bp<- ggplot(df, aes(x="", y=value, fill=group))+
+ geom_bar(width = 1, stat = "identity")
> pie <- bp + coord_polar("y", start=0)
> pie
> pie + scale_fill_manual(values=c("#999999", "#E69F00", "#56B4E9"))
> ggplot(PlantGrowth, aes(x=factor(1), fill=group))+
+ geom_bar(width = 1)+
+ coord_polar("y")
> ggplot(PlantGrowth, aes(x=factor(1), fill=group))+
+ geom_bar(width = 1)+
+ coord_polar("y")
> blank_theme <- theme_minimal()+
+ theme(
+ axis.title.x = element_blank(),
+ axis.title.y = element_blank(),
+ panel.border = element_blank(),
+ panel.grid=element_blank(),
+ axis.ticks = element_blank(),
+ plot.title=element_text(size=14, face="bold")
+ )
> library(scales)
> pie + scale_fill_grey() + blank_theme +
+ theme(axis.text.x=element_blank()) +
+ geom_text(aes(y = value/3 + c(0, cumsum(value)[-length(value)]),
+ label = percent(value/100)), size=5
+ )
> pie + scale_fill_brewer("Blues") + blank_theme +
+ theme(axis.text.x=element_blank())+
+ geom_text(aes(y = value/3 + c(0, cumsum(value)[-length(value)]),
+ label = percent(value/100)), size=5)
>
ggplot2
correlation matrix
> mydata <- mtcars[, c(1,3,4,5,6,7)]
> cormat <- round(cor(mydata),2)
> library(reshape2)
> melted_cormat <- melt(cormat)
> head(melted_cormat)
library(ggplot2)
> ggplot(data = melted_cormat, aes(Var2, Var1, fill = value))+
geom_tile(color = "white")+
scale_fill_gradient2(low = "purple", high = "red", mid = "white",
midpoint = 0, limit = c(-1,1), space = "Lab",
name="Pearson\n Correlation") +
theme_minimal()+
theme(axis.text.x = element_text(angle = 45, vjust = 1,
size = 12, hjust = 1))+
coord_fixed()
Plot
> ohio <- midwest %>%
+ filter(state == "OH") %>%
+ select(county, percollege) %>%
+ arrange(percollege) %>%
+ mutate(Avg = mean(percollege, na.rm = TRUE),
+ Above = ifelse(percollege - Avg > 0, TRUE, FALSE),
+ county = factor(county, levels = .$county)
ggplot(ohio, aes(percollege, county, color = Above)) +
+ geom_segment(aes(x = Avg, y = county, xend = percollege, yend = county), color = "grey50") + ggtitle("preprared by Volkan OBAN using R - ggplot2 - data(midwest) ") +
+ geom_point()
rworldmap
> library(rworldmap)
> newmap <- getMap(resolution = "high")
> plot(newmap,main=" R - rworldmap",
+ xlim = c(-20, 59),
+ ylim = c(35, 71),
+ asp = 1)
canvasXpress package
> data <- t(iris[,1:4])
> varAnnot <- as.matrix(iris[,5])
> colnames(varAnnot) <- "Species"
> canvasXpress(t(data),varAnnot=varAnnot, graphType='Scatter3D', colorBy='Species')
canvasXpress package
> data <- t(iris[,1:4])
> smpAnnot <- as.matrix(iris[,5])
> colnames(smpAnnot) <- "Species"
> canvasXpress(data,title="by Volkan OBAN using R \n canvasXpress package", smpAnnot=smpAnnot, graphType='Boxplot', groupingFactors=list('Species'))
> # or
> canvasXpress(data,title="by Volkan OBAN using R \n canvasXpress package",smpAnnot=smpAnnot, graphType='Boxplot', afterRender=list(list('groupSamples', list('Species'))))
ggplot2
> library(ggplot2)
> g <- ggplot(mpg, aes(manufacturer))
> g + geom_bar(aes(fill=class), width = 0.5) +
+ theme(axis.text.x = element_text(angle=65, vjust=0.6)) +
+ labs(title="by Volkan OBAN using R",
+ subtitle=" Categorywise Bar Chart \n Manufacturer of vehicles",
+ caption="Source: Manufacturers from 'mpg' dataset")
ggmap-İzmir
qmap(location = "izmir")
waffle and gridExtra
gridExtra::grid.arrange(
+ waffle(c(Volkan=50, Oban=50), rows=5,title="by Volkan OBAN using R - gridExtra and waffle packages", xlab="R-waffle package"),
+ waffle(c(Oban=25, Volkan=75), rows=5), waffle(c(Oban=7, Volkan=93), rows=5), waffle(c(Oban=42, Volkan=58), rows=5), waffle(c(Oban=2, Volkan=98), rows=5), waffle(c(oban=63, Volkan=37), rows=5),waffle(c(Oban=2, Volkan=98), rows=5), waffle(c(oban=75, Volkan=25), rows=5),waffle(c(Oban=15, Volkan=85), rows=5), waffle(c(oban=63, Volkan=37), rows=5),waffle(c(Oban=0, Volkan=100), rows=5), waffle(c(oban=100, Volkan=0), rows=5) )
plotrix
> slices <- c(18, 12, 4, 16, 8, 9, 12)
> labels <- c("A", "B", "C", "X", "V", "O", "Z")
> library(plotrix)
> pie3D(slices,labels=labels,explode=0.1, main=" 3D- explodated Pie Chart")
ggraph
ref: https://www.r-bloggers.com/introduction-to-ggraph-layouts/
ggbeeswarm
> library(gridExtra)
> dat <- list( 'Normal'=rnorm(50),'Dense normal'= rnorm(500),'Bimodal'=c(rnorm(100), rnorm(100,5)), 'Trimodal'=c(rnorm(100), rnorm(100,5),rnorm(100,-3))
+ )
> labs<-rep(names(dat),sapply(dat,length))
> labs<-factor(labs,levels=unique(labs))
> dat<-unlist(dat)
>
>
>
>
>
> p1<-ggplot(mapping=aes(labs, dat)) +geom_quasirandom(method='smiley',alpha=.2) + ggtitle('Default (n/5)') + labs(x='Volkan OBAN')
> p2<-ggplot(mapping=aes(labs, dat)) + geom_quasirandom(method='smiley',nbins=50,alpha=.2) +ggtitle('nbins=50')
> p3<-ggplot(mapping=aes(labs, dat)) +geom_quasirandom(method='smiley',nbins=100,alpha=.2) + ggtitle('nbins=100')
> p4<-ggplot(mapping=aes(labs, dat)) +geom_quasirandom(method='smiley',nbins=250,alpha=.2) +ggtitle('nbins=250')
> grid.arrange(p1, p2, p3, p4, ncol=1)
>
psych package
ref:
https://cran.r-project.org/web/packages/psych/psych.pdf
factor Analysis- ggplot2 grid gridExtra and psych
ref: http://rpubs.com/danmirman/plotting_factor_analysis
ggtree
pp <- ggtree(tree) %>% phylopic("79ad5f09-cf21-4c89-8e7d-0c82a00ce728", print(pp)
ggtree
ref : https://bioconductor.org/packages/devel/bioc/manuals/ggtree/man/ggtree.pdf
mlrMBO
library(mlrMBO)
fun = makeSingleObjectiveFunction(
name = "SineMixture",
fn = function(x) sin(x[1])*cos(x[2])/2 + 0.04 * sum(x^2),
par.set = makeNumericParamSet(id = "x", len = 2, lower = -5, upper = 5)
)
ctrl = makeMBOControl()
# For this numeric optimization we are going to use the Expected Improvement as infill criterion:
ctrl = setMBOControlInfill(ctrl, crit = crit.ei)
# We will allow for exactly 25 evaluations of the objective function:
ctrl = setMBOControlTermination(ctrl, max.evals = 25L)
library(ggplot2)
des = generateDesign(n = 8L, par.set = getParamSet(fun), fun = lhs::randomLHS)
autoplot(fun, render.levels = TRUE) + geom_point(data = des)
mlrMBO ecr and plot3D
set.seed(1)
library(mlrMBO)
fun = makeSingleObjectiveFunction(
name = "SineMixture",
fn = function(x) sin(x[1])*cos(x[2])/2 + 0.04 * sum(x^2),
par.set = makeNumericParamSet(id = "x", len = 2, lower = -5, upper = 5)
)
library(plot3D)
plot3D(fun, contour = TRUE, lightning = TRUE)
ggforce
rocketData <- data.frame(
x = c(1,1,2,2),
y = c(1,2,2,3)
)
rocketData <- do.call(rbind, lapply(seq_len(500)-1, function(i) {
rocketData$y <- rocketData$y - c(0,i/500);
rocketData$group <- i+1;
rocketData
}))
rocketData2 <- data.frame(
x = c(2, 2.25, 2),
y = c(2, 2.5, 3)
)
rocketData2 <- do.call(rbind, lapply(seq_len(500)-1, function(i) {
rocketData2$x[2] <- rocketData2$x[2] - i*0.25/500;
rocketData2$group <- i+1 + 500;
rocketData2
}))
ggplot() + geom_link(aes(x=2, y=2, xend=3, yend=3, alpha=..index..,
size = ..index..), colour='goldenrod', n=500) +
geom_bezier(aes(x=x, y=y, group=group, colour=..index..),
data=rocketData) +
geom_bezier(aes(x=y, y=x, group=group, colour=..index..),
data=rocketData) +
geom_bezier(aes(x=x, y=y, group=group, colour=1),
data=rocketData2) +
geom_bezier(aes(x=y, y=x, group=group, colour=1),
data=rocketData2) +
geom_text(aes(x=1.65, y=1.65, label='vvv', angle=45),
colour='white', size=15) +
coord_fixed() +
scale_x_reverse() +
scale_y_reverse() +
scale_alpha(range=c(1, 0), guide='none') +
scale_size_continuous(range=c(20, 0.1), trans='exp',
guide='none') +
scale_color_continuous(guide='none') +
xlab('') + ylab('') +
ggtitle('ggforce: ggplot2') +
theme(plot.title = element_text(size = 20))
LDA-ggplot2
MASS package
data(iris)
corrplot
M <- cor(mtcars)
ord <- corrMatOrder(M, order = "AOE")
M2 <- M[ord,ord]
corrplot.mixed(M2)
corrplot.mixed(M2, lower = "ellipse", upper = "circle")
corrplot.mixed(M2, lower = "square", upper = "circle")
corrplot.mixed(M2, lower = "shade", upper = "circle")
corrplot.mixed(M2, tl.pos = "lt")
corrplot.mixed(M2, tl.pos = "lt", diag = "u")
corrplot.mixed(M2, tl.pos = "lt", , diag = "l")
corrplot
data(mtcars)
M <- cor(mtcars)
## different color series
col1 <- colorRampPalette(c("#7F0000","red","#FF7F00","yellow","white",
"cyan", "#007FFF", "blue","#00007F"))
col2 <- colorRampPalette(c("#67001F", "#B2182B", "#D6604D", "#F4A582", "#FDDBC7",
"#FFFFFF", "#D1E5F0", "#92C5DE", "#4393C3", "#2166AC", "#053061"))
col3 <- colorRampPalette(c("red", "white", "blue"))
col4 <- colorRampPalette(c("#7F0000","red","#FF7F00","yellow","#7FFF7F",
"cyan", "#007FFF", "blue","#00007F"))
wb <- c("white","black")
par(ask = TRUE)
## different color scale and methods to display corr-matrix
corrplot(M, method = "number", col = "black", cl.pos = "n")
corrplot(M, method = "number")
corrplot(M)
corrplot(M, order = "AOE")
corrplot(M, order = "AOE", addCoef.col = "grey")
corrplot(M, order = "AOE", col = col1(20), cl.length = 21, addCoef.col = "grey")
corrplot(M, order = "AOE", col = col1(10), addCoef.col = "grey")
corrplot(M, order = "AOE", col = col2(200))
corrplot(M, order = "AOE", col = col2(200), addCoef.col = "grey")
corrplot(M, order = "AOE", col = col2(20), cl.length = 21, addCoef.col = "grey")
corrplot(M, order = "AOE", col = col2(10), addCoef.col = "grey")
ggmap
> world <- map_data("world")
Attaching package: ‘maps’
The following object is masked from ‘package:plyr’:
ozone
> worldmap <- ggplot(world, aes(long, lat, group = group)) +
+ geom_path() +
+ scale_y_continuous(NULL, breaks = (-2:3) * 30, labels = NULL) +
+ scale_x_continuous(NULL, breaks = (-4:4) * 45, labels = NULL)
>
> worldmap + coord_map()
> # Some crazier projections
> worldmap + coord_map("ortho")
> worldmap + coord_map("stereographic")
ggmap
> world <- map_data("world")
Attaching package: ‘maps’
The following object is masked from ‘package:plyr’:
ozone
> worldmap <- ggplot(world, aes(long, lat, group = group)) +
+ geom_path() +
+ scale_y_continuous(NULL, breaks = (-2:3) * 30, labels = NULL) +
+ scale_x_continuous(NULL, breaks = (-4:4) * 45, labels = NULL)
>
> worldmap + coord_map()
> # Some crazier projections
> worldmap + coord_map("ortho")
> worldmap + coord_map("stereographic")
ggplot2
ref: http://jdobr.es/blog/data-vis-with-ggplot/
ggplot2
ref: http://jdobr.es/blog/data-vis-with-ggplot/
chemmineR package.
data(sdfsample)
(sdfset <- sdfsample)
## Plot single compound structure
plotStruc(sdfset[[1]])
## Plot several compounds structures
plot(sdfset[1:4])
## Highlighting substructures (here all rings)
myrings <- as.numeric(gsub(".*_", "", unique(unlist(rings(sdfset[1])))))
plot(sdfset[1], colbonds=myrings)
## Customize plot
plot(sdfset[1:4], griddim=c(2,2), print_cid=letters[1:4], print=FALSE, noHbonds=FALSE)
chemmineR package.
## Import SDFset sample set
data(sdfsample)
(sdfset <- sdfsample)
## Plot single compound structure
plotStruc(sdfset[[1]])
## Plot several compounds structures
plot(sdfset[1:4])
## Highlighting substructures (here all rings)
myrings <- as.numeric(gsub(".*_", "", unique(unlist(rings(sdfset[1])))))
plot(sdfset[1], colbonds=myrings)
chemmineR package.
data(sdfsample)
(sdfset <- sdfsample)
## Plot single compound structure
plotStruc(sdfset[[1]])
## Plot several compounds structures
plot(sdfset[1:4])
chemmineR package.
data(sdfsample)
sdfset <- sdfsample
## Create bond matrix for first two molecules in sdfset
conMA(sdfset[1:2], exclude=c("H"))
## Return bond matrix for first molecule and plot its structure with atom numbering
conMA(sdfset[[1]], exclude=c("H"))
plot(sdfset[1], atomnum = TRUE, noHbonds=FALSE , no_print_atoms = "", atomcex=0.8)
ref:https://www.bioconductor.org/packages/devel/bioc/manuals/ChemmineR/man/ChemmineR.pdf
grid package
dsmall <- diamonds[sample(nrow(diamonds), 1000), ]
> library(grid)
> a <- ggplot(dsmall, aes(color, price/carat)) + geom_jitter(size=4, alpha = I(1 / 1.5), aes(color=color))
> b <- ggplot(dsmall, aes(color, price/carat, color=color)) + geom_boxplot()
> c <- ggplot(dsmall, aes(color, price/carat, fill=color)) + geom_boxplot() + theme(legend.position = "none")
> grid.newpage() # Open a new page on grid device
> pushViewport(viewport(layout = grid.layout(2, 2))) # Assign to device viewport with 2 by 2 grid layout
> print(a, vp = viewport(layout.pos.row = 1, layout.pos.col = 1:2))
> print(b, vp = viewport(layout.pos.row = 2, layout.pos.col = 1))
> print(c, vp = viewport(layout.pos.row = 2, layout.pos.col = 2, width=0.3, height=0.3, x=0.8, y=0.8))
ggplot2
df <- data.frame(group = rep(c("Above", "Below"), each=10), x = rep(1:10, 2), y = c(runif(10, 0, 1), runif(10, -1, 0)))
> p <- ggplot(df, aes(x=x, y=y, fill=group)) + geom_bar(stat="identity", position="identity")
> p
ggplot2
ref: https://learnr.wordpress.com/page/4/
Dikesh Jariwala
Create Air Travel Route Maps in ggplot---R-bloggers
R-bloggers
# Read flight list
flights <- read.csv("flights.csv", stringsAsFactors = FALSE)
# Lookup coordinates
library(ggmap)
airports <- unique(c(flights$From, flights$To))
coords <- geocode(airports)
airports <- data.frame(airport=airports, coords)
flights <- merge(flights, airports, by.x="To", by.y="airport")
flights <- merge(flights, airports, by.x="From", by.y="airport")
# Plot flight routes
library(ggplot2)
library(ggrepel)
worldmap <- borders("world", colour="#efede1", fill="#efede1") # create a layer of borders
ggplot() + worldmap +
geom_curve(data=flights, aes(x = lon.x, y = lat.x, xend = lon.y, yend = lat.y), col = "#b29e7d", size = 1, curvature = .2) +
geom_point(data=airports, aes(x = lon, y = lat), col = "#970027") +
geom_text_repel(data=airports, aes(x = lon, y = lat, label = airport), col = "black", size = 2, segment.color = NA) +
theme(panel.background = element_rect(fill="white"),
axis.line = element_blank(),
axis.text.x = element_blank(),
axis.text.y = element_blank(),
axis.ticks = element_blank(),
axis.title.x = element_blank(),
axis.title.y = element_blank()
)
rAmcharts
Funnel
qgraph
qgraph(dat.3[-c(1:3,13:15),],layout=L.3,nNodes=30,directed=FALSE,edge.labels=TRUE,esize=14)
qgraph
> dat.3 <- matrix(c(1:15*2-1,1:15*2),,2)
> dat.3 <- cbind(dat.3,round(seq(-0.7,0.7,length=15),1))
> L.3 <- matrix(1:30,nrow=2)
> # Different esize:
> qgraph(dat.3,layout=L.3,directed=FALSE,edge.labels=TRUE,esize=14)
> qgraph(dat.3[-c(1:3,13:15),],layout=L.3,nNodes=30,directed=FALSE,
+ edge.labels=TRUE,esize=14)
>
> qgraph(dat.3,layout=L.3,directed=FALSE,edge.labels=TRUE,esize=14,maximum=1)
> title("by Volkan OBAN using R-qgraph package",line=2.5)
explodingboxplotR package
> library(explodingboxplotR)
>
> # use this to replicate
> # from ?boxplot
> #boxplot(count ~ spray, data = InsectSprays, col = "lightgray")
>
> exploding_boxplot(
+ data.frame(
+ rowname = rownames(InsectSprays),
+ InsectSprays,
+ stringsAsFactors = FALSE),
+ y = "count",
+ group = "spray",
+ color = "spray",
+ label = "rowname"
+ )
threejs
z <- seq(-10, 10, 0.1)
x <- cos(z)
y <- sin(z)
scatterplot3js(x, y, z, color=rainbow(length(z)))
threejs
N <- 100
i <- sample(3, N, replace=TRUE)
x <- matrix(rnorm(N*3),ncol=3)
lab <- c("small", "bigger", "biggest")
scatterplot3js(x, color=rainbow(N), labels=lab[i], size=i, renderer="canvas")
threejs
data(flights)
# Approximate locations as factors
dest <- factor(sprintf("%.2f:%.2f",flights[,3], flights[,4]))
# A table of destination frequencies
freq <- sort(table(dest), decreasing=TRUE)
# The most frequent destinations in these data, possibly hub airports?
frequent_destinations <- names(freq)[1:10]
# Subset the flight data by destination frequency
idx <- dest %in% frequent_destinations
frequent_flights <- flights[idx, ]
# Lat/long and counts of frequent flights
ll <- unique(frequent_flights[,3:4])
# Plot frequent destinations as bars, and the flights to and from
# them as arcs. Adjust arc width and color by frequency.
globejs(lat=ll[,1], long=ll[,2], arcs=frequent_flights,
arcsHeight=0.3, arcsLwd=2, arcsColor="#ffff00", arcsOpacity=0.15,
atmosphere=TRUE, color="#00aaff", pointsize=0.5)
threejs
library(rgdal)
library(threejs)
# Download MODIS 16-day 1 degree Vegetation Index data manually from
# http://neo.sci.gsfc.nasa.gov/view.php?datasetId=MOD13A2_M_NDVI
# or use the following cached copy from May 25, 2014
cache <- tempfile()
writeBin(
readBin(
url("http://illposed.net/nycr2015/MOD13A2_E_NDVI_2014-05-25_rgb_360x180.TIFF",
open="rb"),
what="raw", n=1e6),
con=cache)
x <- readGDAL(cache)
# Obtain lat/long coordinates and model values as a data.frame
x <- as.data.frame(cbind(coordinates(x), x@data[,1]))
names(x) <- c("long","lat","value")
# Remove ocean areas and NA values
x <- x[x$value < 255,]
x <- na.exclude(x)
# Cut the values up into levels corresponding to the
# 99th, 95th, 90th, percentiles and then all the rest.
x$q <- as.numeric(
cut(x$value,
breaks=quantile(x$value, probs=c(0,0.90,0.95,0.99,1)),
include.lowest=TRUE))
# Colors for each level
col = c("#0055ff","#00aaff","#00ffaa","#aaff00")[x$q]
# bling out the data
globejs(lat=x$lat, long=x$long,
val=x$q^3, # Bar height
color=col,
pointsize=0.5,
atmosphere=TRUE)
DiagrammeR
library(DiagrammeR)
>
> create_random_graph(140, 100, set_seed = 23) %>%
+ join_node_attrs(get_w_connected_cmpts(.)) %>%
+ select_nodes_by_id(get_articulation_points(.)) %>%
+ set_node_attrs_ws("peripheries", 2) %>%
+ set_node_attrs_ws("width", 0.65) %>%
+ set_node_attrs_ws("height", 0.65) %>%
+ set_node_attrs_ws("penwidth", 3) %>%
+ clear_selection() %>%
+ add_global_graph_attrs(
+ attr =
+ c("color", "penwidth", "width", "height"),
+ value =
+ c("gray80", "3", "0.5", "0.5"),
+ attr_type =
+ c("edge", "edge", "node", "node")) %>%
+ colorize_node_attrs(
+ node_attr_from = "wc_component",
+ node_attr_to = "fillcolor",
+ alpha = 80) %>%
+ set_node_attr_to_display() %>%
+ select_nodes_by_degree("deg >= 3") %>%
+ trav_both_edge() %>%
+ set_edge_attrs_ws("penwidth", 4) %>%
+ set_edge_attrs_ws("color", "gray60") %>%
+ clear_selection() %>%
+ render_graph()
highcharter package.
ref. and code: https://www.r-bloggers.com/giving-a-thematic-touch-to-your-interactive-chart/
highcharter package.theme
ref:
https://www.r-bloggers.com/giving-a-thematic-touch-to-your-interactive-chart/
spnet package
data(world.map.simplified, package = "spnet")
graph.map.plot.position(world.map.simplified)
graph.map.plot.position(world.map.simplified, cex = 0.4)
graph.map.plot.position(world.map.simplified, label = 'ID ', cex = 0.3)
ndtv
ref: https://cran.r-project.org/web/packages/ndtv/ndtv.pdf
ndtv
data(McFarland_cls33_10_16_96)
coords<-plot(cls33_10_16_96)
# center layout coords with 100 unit area
layout.center(coords,xlim=c(0,100),ylim=c(0,100))
# rescale layout coords to unit interval
layout.normalize(coords)
qgraph
ref:https://cran.r-project.org/web/packages/qgraph/qgraph.pdf
tsna
library(networkDynamicData)
data(vanDeBunt_students)
times<-get.change.times(vanDeBunt_students)
vanDProj<-timeProjectedNetwork(vanDeBunt_students,onsets = times,termini = times)
# plot it with gray for the time edges
plot(vanDProj,
arrowhead.cex = 0,
edge.col=ifelse(vanDProj%e%'edge.type'=='within_slice','black','gray'),vertex.cex=0.7,mode='kamadakawai')
geomnet
library(geomnet)
> library(dplyr)
> # create plot
> ggplot(data = soccernet, aes(from_id = home, to_id = away)) +
+ geom_net(aes(colour = div, group = div), ealpha = .25,
+ layout.alg = 'fruchtermanreingold') +
+ facet_wrap(~season) +
+ theme_net()
geomnet
> ggplot(data = lesmisnet, aes(from_id = from, to_id = to,
+ linewidth = degree / 5 + 0.1 )) +
+ geom_net(aes(size = degree, alpha = degree),
+ colour = "grey30", ecolour = "grey60",
+ layout.alg = "fruchtermanreingold", labelon = TRUE, vjust = -0.75) +
+ scale_alpha(range = c(0.3, 1)) + theme_net() + ggtitle("by Volkan OBAN using R - geomnet")
geomnet
data(football)
ftnet <- fortify(as.edgedf(football$edges), football$vertices)
p <- ggplot(data=ftnet, aes(from_id=from_id, to_id=to_id))
p + geom_net(aes(colour=value), linewidth=0.75, size=4.5, ecolour="grey80") +
scale_colour_brewer("Conference", palette="Paired") + theme_net() +
theme(legend.position="bottom")
geomnet
emailnet <- fortify(emailedges, email$nodes, group = "day")
Joining edge and node information by from_id and label respectively.
> ggplot(data = emailnet, aes(from_id = from, to_id = to_id)) +
+ geom_net(aes(colour= CurrentEmploymentType), linewidth=0.5, fiteach=TRUE) +
+ scale_colour_brewer(palette="Set2") + facet_wrap(~day, nrow=2) + theme(legend.position="bottom") + ggtitle("by Volkan OBAN using R - geomnet")
geomnet
emailedges <- as.edgedf(subset(email$edges, nrecipients < 54))
emailnet <- fortify(emailedges, email$nodes)
#no facets
ggplot(data = emailnet, aes(from_id = from_id, to_id = to_id)) +
geom_net(aes(colour= CurrentEmploymentType), linewidth=0.5) +
scale_colour_brewer(palette="Set2")
geomnet
data(theme_elements)
TEnet <- fortify(as.edgedf(theme_elements$edges[,c(2,1)]), theme_elements$vertices)
ggplot(data = TEnet, aes(from_id = from_id, to_id = to_id)) +
geom_net(labelon=TRUE, vjust=-0.5)
geomnet
library(geomnet)
Zorunlu paket yükleniyor: ggplot2
> data(blood)
> p <- ggplot(data = blood$edges, aes(from_id = from, to_id = to))
> p + geom_net(vertices=blood$vertices, aes(colour=..type..)) + theme_net()
>
> bloodnet <- fortify(as.edgedf(blood$edges), blood$vertices)
Using from as the from node column and to as the to node column.
If this is not correct, rewrite dat so that the first 2 columns are from and to node, respectively.
Joining edge and node information by from_id and label respectively.
> p <- ggplot(data = bloodnet, aes(from_id = from_id, to_id = to_id))
> p + geom_net()
> p + geom_net(aes(colour=rho)) + theme_net()
> p + geom_net(aes(colour=rho), labelon=TRUE, vjust = -0.5)
> p + geom_net(aes(colour=rho, linetype = group_to, label = from_id),
+ vjust=-0.5, labelcolour="black", directed=TRUE) +
+ theme_net() + ggtitle(" prepared by VOLKAN OBAN using R \n geomnet package")
> p + geom_net(colour = "orange", layout.alg = 'circle', size = 6)
> p + geom_net(colour = "orange", layout.alg = 'circle', size = 6, linewidth=.75)
> p + geom_net(colour = "orange", layout.alg = 'circle', size = 0, linewidth=.75,directed = TRUE)
> p + geom_net(aes(size=Predominance, colour=rho, shape=rho, linetype=group_to),linewidth=0.75, labelon =TRUE, labelcolour="black") +
+ facet_wrap(~Ethnicity) +
+ scale_colour_brewer(palette="Set2")
geomnet
library(geomnet)
data(blood)
p <- ggplot(data = blood$edges, aes(from_id = from, to_id = to))
p + geom_net(vertices=blood$vertices, aes(colour=..type..)) + theme_net()
bloodnet <- fortify(as.edgedf(blood$edges), blood$vertices)
p <- ggplot(data = bloodnet, aes(from_id = from_id, to_id = to_id))
p + geom_net()
p + geom_net(aes(colour=rho)) + theme_net()
p + geom_net(aes(colour=rho), labelon=TRUE, vjust = -0.5)
p + geom_net(aes(colour=rho, linetype = group_to, label = from_id),
vjust=-0.5, labelcolour="black", directed=TRUE) +
theme_net()
Latin Square
latinSq(20)
ref:http://rstudio-pubs-static.s3.amazonaws.com/1915_bd5807659c42432a9929af403b2bda5c.html
Latin Square
require(reshape2)
## Loading required package: reshape2
require(ggplot2)
## Loading required package: ggplot2
require(RColorBrewer)
## Loading required package: RColorBrewer
latinSq = function(n) {
v = rep(NA, n^2)
v[n * (1:n) - (n - 1)] = 1:n
mem = 1
for (i in 1:(n^2)) {
if (!is.na(v[i]))
mem = ifelse(v[i] < n, v[i] + 1, 1)
if (is.na(v[i])) {
v[i] = mem
mem = ifelse(mem < n, mem + 1, 1)
}
}
dim(v) = c(n, n)
lsqm = melt(v)
if (n != 7)
gg <- ggplot(lsqm, aes(x = Var1, y = Var2, fill = value, label = LETTERS[value]))
if (n == 7) {
LATINSQ = c("L", "A", "T", "I", "N", "S", "Q")[lsqm$value]
lsqm = data.frame(lsqm, LATINSQ)
gg <- ggplot(lsqm, aes(x = Var1, y = Var2, fill = value, label = LATINSQ))
}
ggPrint <- gg + geom_tile() + geom_text() + scale_fill_gradientn(colours = brewer.pal(n,
"Spectral")) + theme_bw() + theme(axis.text.x = element_blank(), axis.text.y = element_blank(),
axis.title.x = element_blank(), axis.title.y = element_blank())
ggPrint
}
latinSq(6)