[wip] ! Разобрался с проблематикой русского языка в ggiraph !

iMissile · Sep 25, 2018 · 0ae7c1e · 0ae7c1e
1 parent 472d9ab
commit 0ae7c1e
Show file tree

Hide file tree

Showing 4 changed files with 359 additions and 43 deletions.
diff --git a/82 interactivity/data/ppg2008.csv b/82 interactivity/data/ppg2008.csv
@@ -0,0 +1,51 @@
+Name  ,G,MIN,PTS,FGM,FGA,FGP,FTM,FTA,FTP,3PM,3PA,3PP,ORB,DRB,TRB,AST,STL,BLK,TO,PF
+Dwyane Wade ,79,38.6,30.2,10.8,22,0.491,7.5,9.8,0.765,1.1,3.5,0.317,1.1,3.9,5,7.5,2.2,1.3,3.4,2.3
+LeBron James ,81,37.7,28.4,9.7,19.9,0.489,7.3,9.4,0.78,1.6,4.7,0.344,1.3,6.3,7.6,7.2,1.7,1.1,3,1.7
+Kobe Bryant ,82,36.2,26.8,9.8,20.9,0.467,5.9,6.9,0.856,1.4,4.1,0.351,1.1,4.1,5.2,4.9,1.5,0.5,2.6,2.3
+Dirk Nowitzki ,81,37.7,25.9,9.6,20,0.479,6,6.7,0.89,0.8,2.1,0.359,1.1,7.3,8.4,2.4,0.8,0.8,1.9,2.2
+Danny Granger ,67,36.2,25.8,8.5,19.1,0.447,6,6.9,0.878,2.7,6.7,0.404,0.7,4.4,5.1,2.7,1,1.4,2.5,3.1
+Kevin Durant ,74,39,25.3,8.9,18.8,0.476,6.1,7.1,0.863,1.3,3.1,0.422,1,5.5,6.5,2.8,1.3,0.7,3,1.8
+Kevin Martin ,51,38.2,24.6,6.7,15.9,0.42,9,10.3,0.867,2.3,5.4,0.415,0.6,3,3.6,2.7,1.2,0.2,2.9,2.3
+Al Jefferson ,50,36.6,23.1,9.7,19.5,0.497,3.7,5,0.738,0,0.1,0,3.4,7.5,11,1.6,0.8,1.7,1.8,2.8
+Chris Paul ,78,38.5,22.8,8.1,16.1,0.503,5.8,6.7,0.868,0.8,2.3,0.364,0.9,4.7,5.5,11,2.8,0.1,3,2.7
+Carmelo Anthony ,66,34.5,22.8,8.1,18.3,0.443,5.6,7.1,0.793,1,2.6,0.371,1.6,5.2,6.8,3.4,1.1,0.4,3,3
+Chris Bosh ,77,38.1,22.7,8,16.4,0.487,6.5,8,0.817,0.2,0.6,0.245,2.8,7.2,10,2.5,0.9,1,2.3,2.5
+Brandon Roy ,78,37.2,22.6,8.1,16.9,0.48,5.3,6.5,0.824,1.1,2.8,0.377,1.3,3.4,4.7,5.1,1.1,0.3,1.9,1.6
+Antawn Jamison ,81,38.2,22.2,8.3,17.8,0.468,4.2,5.6,0.754,1.4,3.9,0.351,2.4,6.5,8.9,1.9,1.2,0.3,1.5,2.7
+Tony Parker ,72,34.1,22,8.9,17.5,0.506,3.9,5,0.782,0.3,0.9,0.292,0.4,2.7,3.1,6.9,0.9,0.1,2.6,1.5
+Amare Stoudemire ,53,36.8,21.4,7.6,14.1,0.539,6.1,7.3,0.835,0.1,0.1,0.429,2.2,5.9,8.1,2,0.9,1.1,2.8,3.1
+Joe Johnson ,79,39.5,21.4,7.8,18,0.437,3.8,4.6,0.826,1.9,5.2,0.36,0.8,3.6,4.4,5.8,1.1,0.2,2.5,2.2
+Devin Harris ,69,36.1,21.3,6.6,15.1,0.438,7.2,8.8,0.82,0.9,3.2,0.291,0.4,2.9,3.3,6.9,1.7,0.2,3.1,2.4
+Michael Redd ,33,36.4,21.2,7.5,16.6,0.455,4,4.9,0.814,2.1,5.8,0.366,0.7,2.5,3.2,2.7,1.1,0.1,1.6,1.4
+David West ,76,39.3,21,8,17,0.472,4.8,5.5,0.884,0.1,0.3,0.24,2.1,6.4,8.5,2.3,0.6,0.9,2.1,2.7
+Zachary Randolph ,50,35.1,20.8,8.3,17.5,0.475,3.6,4.9,0.734,0.6,1.9,0.33,3.1,6.9,10.1,2.1,0.9,0.3,2.3,2.7
+Caron Butler ,67,38.6,20.8,7.3,16.2,0.453,5.1,6,0.858,1,3.1,0.31,1.8,4.4,6.2,4.3,1.6,0.3,3.1,2.5
+Vince Carter ,80,36.8,20.8,7.4,16.8,0.437,4.2,5.1,0.817,1.9,4.9,0.385,0.9,4.2,5.1,4.7,1,0.5,2.1,2.9
+Stephen Jackson ,59,39.7,20.7,7,16.9,0.414,5,6,0.826,1.7,5.2,0.338,1.2,3.9,5.1,6.5,1.5,0.5,3.9,2.6
+Ben Gordon ,82,36.6,20.7,7.3,16,0.455,4,4.7,0.864,2.1,5.1,0.41,0.6,2.8,3.5,3.4,0.9,0.3,2.4,2.2
+Dwight Howard ,79,35.7,20.6,7.1,12.4,0.572,6.4,10.7,0.594,0,0,0,4.3,9.6,13.8,1.4,1,2.9,3,3.4
+Paul Pierce ,81,37.4,20.5,6.7,14.6,0.457,5.7,6.8,0.83,1.5,3.8,0.391,0.7,5,5.6,3.6,1,0.3,2.8,2.7
+Al Harrington ,73,34.9,20.1,7.3,16.6,0.439,3.2,4,0.793,2.3,6.4,0.364,1.4,4.9,6.2,1.4,1.2,0.3,2.2,3.1
+Jamal Crawford ,65,38.1,19.7,6.4,15.7,0.41,4.6,5.3,0.872,2.2,6.1,0.36,0.4,2.6,3,4.4,0.9,0.2,2.3,1.4
+Yao Ming ,77,33.6,19.7,7.4,13.4,0.548,4.9,5.7,0.866,0,0,1,2.6,7.2,9.9,1.8,0.4,1.9,3,3.3
+Richard Jefferson ,82,35.9,19.6,6.5,14.9,0.439,5.1,6.3,0.805,1.4,3.6,0.397,0.7,3.9,4.6,2.4,0.8,0.2,2,3.1
+Jason Terry ,74,33.6,19.6,7.3,15.8,0.463,2.7,3,0.88,2.3,6.2,0.366,0.5,1.9,2.4,3.4,1.3,0.3,1.6,1.9
+Deron Williams ,68,36.9,19.4,6.8,14.5,0.471,4.8,5.6,0.849,1,3.3,0.31,0.4,2.5,2.9,10.7,1.1,0.3,3.4,2
+Tim Duncan ,75,33.7,19.3,7.4,14.8,0.504,4.5,6.4,0.692,0,0,0,2.7,8,10.7,3.5,0.5,1.7,2.2,2.3
+Monta Ellis ,25,35.6,19,7.8,17.2,0.451,3.1,3.8,0.83,0.3,1,0.308,0.6,3.8,4.3,3.7,1.6,0.3,2.7,2.7
+Rudy Gay ,79,37.3,18.9,7.2,16,0.453,3.3,4.4,0.767,1.1,3.1,0.351,1.4,4.2,5.5,1.7,1.2,0.7,2.6,2.8
+Pau Gasol ,81,37.1,18.9,7.3,12.9,0.567,4.2,5.4,0.781,0,0,0.5,3.2,6.4,9.6,3.5,0.6,1,1.9,2.1
+Andre Iguodala ,82,39.8,18.8,6.6,14,0.473,4.6,6.4,0.724,1,3.2,0.307,1.1,4.6,5.7,5.3,1.6,0.4,2.7,1.9
+Corey Maggette ,51,31.1,18.6,5.7,12.4,0.461,6.7,8.1,0.824,0.5,1.9,0.253,1,4.6,5.5,1.8,0.9,0.2,2.4,3.8
+O.J. Mayo ,82,38,18.5,6.9,15.6,0.438,3,3.4,0.879,1.8,4.6,0.384,0.7,3.1,3.8,3.2,1.1,0.2,2.8,2.5
+John Salmons ,79,37.5,18.3,6.5,13.8,0.472,3.6,4.4,0.83,1.6,3.8,0.417,0.7,3.5,4.2,3.2,1.1,0.3,2.1,2.3
+Richard Hamilton ,67,34,18.3,7,15.6,0.447,3.3,3.9,0.848,1,2.8,0.368,0.7,2.4,3.1,4.4,0.6,0.1,2,2.6
+Ray Allen ,79,36.3,18.2,6.3,13.2,0.48,3,3.2,0.952,2.5,6.2,0.409,0.8,2.7,3.5,2.8,0.9,0.2,1.7,2
+LaMarcus Aldridge ,81,37.1,18.1,7.4,15.3,0.484,3.2,4.1,0.781,0.1,0.3,0.25,2.9,4.6,7.5,1.9,1,1,1.5,2.6
+Josh Howard ,52,31.9,18,6.8,15.1,0.451,3.3,4.2,0.782,1.1,3.2,0.345,1.1,3.9,5.1,1.6,1.1,0.6,1.7,2.6
+Maurice Williams ,81,35,17.8,6.5,13.9,0.467,2.6,2.8,0.912,2.3,5.2,0.436,0.6,2.9,3.4,4.1,0.9,0.1,2.2,2.7
+Shaquille O'neal ,75,30.1,17.8,6.8,11.2,0.609,4.1,6.9,0.595,0,0,0,2.5,5.9,8.4,1.7,0.7,1.4,2.2,3.4
+Rashard Lewis ,79,36.2,17.7,6.1,13.8,0.439,2.8,3.4,0.836,2.8,7,0.397,1.2,4.6,5.7,2.6,1,0.6,2,2.5
+Chauncey Billups ,79,35.3,17.7,5.2,12.4,0.418,5.3,5.8,0.913,2.1,5,0.408,0.4,2.6,3,6.4,1.2,0.2,2.2,2
+Allen Iverson ,57,36.7,17.5,6.1,14.6,0.417,4.8,6.1,0.781,0.5,1.7,0.283,0.5,2.5,3,5,1.5,0.1,2.6,1.5
+Nate Robinson ,74,29.9,17.2,6.1,13.9,0.437,3.4,4,0.841,1.7,5.2,0.325,1.3,2.6,3.9,4.1,1.3,0.1,1.9,2.8
diff --git a/82 interactivity/ggplot_heatmap/app.R b/82 interactivity/ggplot_heatmap/app.R
@@ -0,0 +1,77 @@
+# https://github.com/tidyverse/ggplot2/issues/1539
+
+require(quantmod)
+require(ggplot2)
+require(reshape2)
+require(plyr)
+require(scales)
+library(shiny)
+
+#This function is only to produce data
+getData = function(){
+  # Download some Data, e.g. the CBOE VIX 
+  getSymbols("^VIX",src="yahoo")
+
+  # Make a dataframe
+  dat<-data.frame(date=index(VIX),VIX)
+  #cut
+  dat <- dat[dat$date>as.Date("2015-01-01"),]
+
+  # We will facet by year ~ month, and each subgraph will
+  # show week-of-month versus weekday
+  # the year is simple
+  dat$year<-as.numeric(as.POSIXlt(dat$date)$year+1900)
+  # the month too 
+  dat$month<-as.numeric(as.POSIXlt(dat$date)$mon+1)
+  # but turn months into ordered facors to control the appearance/ordering in the presentation
+  dat$monthf<-factor(dat$month,levels=as.character(1:12),labels=c("Jan","Feb","Mar","Apr","May","Jun","Jul","Aug","Sep","Oct","Nov","Dec"),ordered=TRUE)
+  # the day of week is again easily found
+  dat$weekday = as.POSIXlt(dat$date)$wday
+  # again turn into factors to control appearance/abbreviation and ordering
+  # I use the reverse function rev here to order the week top down in the graph
+  # you can cut it out to reverse week order
+  dat$weekdayf<-factor(dat$weekday,levels=rev(1:7),labels=rev(c("Mon","Tue","Wed","Thu","Fri","Sat","Sun")),ordered=TRUE)
+  # the monthweek part is a bit trickier 
+  # first a factor which cuts the data into month chunks
+  dat$yearmonth<-as.yearmon(dat$date)
+  dat$yearmonthf<-factor(dat$yearmonth)
+  # then find the "week of year" for each day
+  dat$week <- as.numeric(format(dat$date,"%W"))
+  # and now for each monthblock we normalize the week to start at 1 
+  dat<-ddply(dat,.(yearmonthf),transform,monthweek=1+week-min(week))
+
+  return(dat)
+
+}
+
+#######################################
+#Shiny Server
+server = function(input,output){
+  data = getData()
+  output$myplot = renderPlot({
+    ggplot(data, aes(monthweek, weekdayf, fill = VIX.Close)) +
+      geom_tile(colour = "white") + 
+      ## >>>>> The following line makes the interactive plot not working w/ ggplot2 2.0.0
+      facet_grid(year~monthf) +
+      ## <<<<<
+      scale_fill_gradient(low="red", high="yellow")
+  })
+  output$x = renderText(input$myplot_click$x)
+  output$y = renderText(input$myplot_click$y)
+}
+
+#Shiny UI
+ui = fluidPage(
+  mainPanel(
+    fluidRow(
+      plotOutput("myplot" ,click = "myplot_click")
+    ),
+    fluidRow(
+      verbatimTextOutput("x"), 
+      verbatimTextOutput("y")
+    )
+
+  )
+)
+
+shinyApp(ui=ui,server=server)
diff --git a/82 interactivity/ggplot_hist/app.R b/82 interactivity/ggplot_hist/app.R
@@ -5,75 +5,81 @@ library(tidyverse)
 library(lubridate)
 library(shiny)
 library(ggiraph)
+library(hrbrthemes)
 
 # Define UI for application that draws a histogram
 ui <- fluidPage(
-
+   
    # Application title
    titlePanel("Old Faithful Geyser Data"),
-
+   
    # Sidebar with a slider input for number of bins
    sidebarLayout(
       sidebarPanel(
-        verbatimTextOutput("info1"),
-        verbatimTextOutput("info2")
+         verbatimTextOutput("info1"),
+         verbatimTextOutput("info2")
       ),
-
+      
       mainPanel(
-        fluidRow(
-          # в ggigraphOutput height не работает, надо задавать размер svg в ggiraph
-          column(6, ggiraphOutput("interactivePlot", height="500px")),
-          column(6, plotOutput("staticPlot", click="plot_click"))
-        )
+         fluidRow(
+            # в ggigraphOutput height не работает, надо задавать размер svg в ggiraph
+            column(6, ggiraphOutput("interactivePlot", height="500px")),
+            column(6, plotOutput("staticPlot", click="plot_click"))
+         )
       )
    )
 )
 
 # Define server logic required to draw a histogram
 server <- function(input, output) {
-
-  tmp_df <- tibble(category=ymd("2017-10-12", "2017-10-11", "2017-10-9", "2017-10-8"),
+   
+   tmp_df <- tibble(category=ymd("2017-10-12", "2017-10-11", "2017-10-9", "2017-10-8"),
                     value=c(4.2, 7.7, 3.9, 6.2),
                     type=c("ПЛОХО", "ХОРОШО", "ХОРОШО", "ПЛОХО")) %>%
-    mutate(layer="L_1")
-
-  demo_df <- bind_rows(tmp_df, tmp_df %>% mutate(value=round(value+runif(n(), -1, 1), 1), layer="L_2")) %>%
-    mutate(id=as.character(row_number()), tooltip=as.character(value))
-
+      mutate(layer="L_1")
+   
+   demo_df <- bind_rows(tmp_df, tmp_df %>% mutate(value=round(value+runif(n(), -1, 1), 1), layer="L_2")) %>%
+      mutate(id=as.character(row_number()), tooltip=as.character(value))
+   
    output$staticPlot <- renderPlot({
-     gp <- ggplot(demo_df, aes(x=category, y=value)) +
-       geom_bar(aes(fill=type, alpha=layer), stat="identity", position="stack") +
-       scale_fill_brewer(palette="Dark2") +
-       scale_alpha_manual(values=c("L_1"=0.5, "L_2"=1)) +
-       facet_wrap(~type)
-
-     gp
+      gp <- ggplot(demo_df, aes(x=category, y=value)) +
+         geom_bar(aes(fill=type, alpha=layer), stat="identity", position="stack") +
+         scale_fill_brewer(palette="Dark2") +
+         scale_alpha_manual(values=c("L_1"=0.5, "L_2"=1)) +
+         facet_wrap(~type)
+      
+      gp
    })
-
+   
    output$interactivePlot <- renderggiraph({
-     gp <- ggplot(demo_df, aes(x=category, y=value, tooltip=value, data_id=id)) +
-       geom_bar_interactive(aes(fill=type, alpha=layer), stat="identity", position="stack") +
-       scale_fill_brewer(palette="Dark2") +
-       scale_alpha_manual(values=c("L_1"=0.5, "L_2"=1)) +
-       facet_wrap(~type)
-
-     # по умолчания ggigraph делает svg viewbox размером 6in x 6in!!!
-     ggiraph(code=print(gp), height_svg=300/72)
-     # ggiraph(code=print(gp))
+      gp <- ggplot(demo_df, aes(x=category, y=value, tooltip=value, data_id=id)) +
+         geom_bar_interactive(aes(fill=type, alpha=layer), stat="identity", position="stack") +
+         scale_fill_brewer(palette="Dark2") +
+         scale_alpha_manual(values=c("L_1"=0.5, "L_2"=1)) +
+         facet_wrap(~type) +
+         # добавим проверку поддержки русских букв
+         xlab("Категория") +
+         ylab("Значение") +
+         ggtitle("Гистограммы по фасетам", subtitle = "Подпись второго уровня") +
+         theme_ipsum_rc()
+
+      # по умолчания ggigraph делает svg viewbox размером 6in x 6in!!!
+      ggiraph(code=print(gp), height_svg=300/72)
+      # ggiraph(code=print(gp))
    })
-
+   
    output$info1 <- renderText({
-     # browser()
-     t <- input$plot_click
-     paste0("x=", input$plot_click$x, "\ny=", input$plot_click$y, "\nfacet=", input$plot_click$panelvar1)
+      # browser()
+      t <- input$plot_click
+      paste0("x=", input$plot_click$x, "\ny=", input$plot_click$y, "\nfacet=", input$plot_click$panelvar1)
    })
-
+   
    output$info2 <- renderText({
-     # browser()
-     t <- input$plot_click
-     paste0("x=", input$plot_click$x, "\ny=", input$plot_click$y, "\nfacet=", input$plot_click$panelvar1)
+      # browser()
+      t <- input$plot_click
+      paste0("x=", input$plot_click$x, "\ny=", input$plot_click$y, "\nfacet=", input$plot_click$panelvar1)
    })
-
+   
 }
 
 # Run the application